James/purr
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Start formatting with stylish-haskell. Start refactoring for clearer types.

Browse Source
This commit is contained in:
James Eversole 2023-01-10 21:53:10 -06:00
parent 84c49319a6
commit cb45c4ce1d
16 changed files with 185 additions and 180 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
Purr.cabal
View File

@ -32,7 +32,6 @@ library
Feature.Sharing.HTTP Feature.Sharing.HTTP
Feature.Sharing.SQLite Feature.Sharing.SQLite
Feature.Sharing.Templates Feature.Sharing.Templates
Feature.Sharing.Types
Lib Lib
other-modules: other-modules:
Paths_Purr Paths_Purr

4
src/Core/Configuration.hs
View File

@ -1,8 +1,8 @@
module Core.Configuration ( main ) where module Core.Configuration ( main ) where
import Core.Types import Core.Types
import Dhall import Dhall
instance FromDhall DhallConfig instance FromDhall DhallConfig

18
src/Core/HTTP.hs
View File

@ -1,16 +1,16 @@
module Core.HTTP ( app ) where module Core.HTTP ( app ) where
import Core.Types import Core.Types
import Core.Templates (renderIndex, renderStyle) import Core.Templates (renderIndex, renderStyle)
import Feature.Sharing.HTTP as Sharing import Feature.Generation.HTTP as Generation
import Feature.Generation.HTTP as Generation import Feature.Sharing.HTTP as Sharing
import Control.Monad.Reader (ask, lift) import Control.Monad.Reader (ask, lift)
import Data.Maybe (Maybe (Nothing)) import Data.Maybe (Maybe (Nothing))
import Network.Wai.Middleware.RequestLogger (logStdoutDev) import Network.Wai.Middleware.RequestLogger (logStdoutDev)
import Network.Wai.Middleware.Static import Network.Wai.Middleware.Static
import Web.Scotty.Trans import Web.Scotty.Trans
app :: PurrApp () app :: PurrApp ()
app = do app = do

14
src/Core/SQLite.hs
View File

@ -1,17 +1,17 @@
module Core.SQLite where module Core.SQLite where
import Core.Types import Core.Types
import Control.Monad.Reader (ask, lift, liftIO) import Control.Monad.Reader (ask, lift, liftIO)
import Database.SQLite.Simple import Database.SQLite.Simple
import Database.SQLite.Simple.FromRow import Database.SQLite.Simple.FromRow
import qualified Data.Text as T import qualified Data.Text as T
main :: String -> IO () main :: String -> IO ()
main db = do main db = do
conn <- open db conn <- open db
execute_ conn execute_ conn
"CREATE TABLE IF NOT EXISTS pws\ "CREATE TABLE IF NOT EXISTS pws\
\ (link TEXT PRIMARY KEY,\ \ (link TEXT PRIMARY KEY,\
\ secret TEXT,\ \ secret TEXT,\

16
src/Core/Templates.hs
View File

@ -1,17 +1,17 @@
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
module Core.Templates ( renderIndex, renderStyle, hxVals ) where module Core.Templates ( renderIndex, renderStyle, hxVals ) where
import Text.Blaze.Html.Renderer.Text (renderHtml) import Text.Blaze.Html
import Text.Blaze.Html import Text.Blaze.Html.Renderer.Text (renderHtml)
import Text.Cassius (cassiusFile, renderCss) import Text.Cassius (cassiusFile, renderCss)
import Text.Hamlet (shamletFile) import Text.Hamlet (shamletFile)
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy as LT
import Prelude import Prelude
renderIndex :: String -> String -> LT.Text renderIndex :: String -> String -> LT.Text
renderIndex link email = renderHtml ( $(shamletFile "./views/index.hamlet") ) renderIndex link email = renderHtml ( $(shamletFile "./views/index.hamlet") )

59
src/Core/Types.hs
View File

@ -1,20 +1,34 @@
module Core.Types where module Core.Types where
import qualified Data.Text.Lazy as LT import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import Control.Monad.Reader (MonadIO, MonadReader, ReaderT) import Control.Monad.Reader (MonadIO, MonadReader, ReaderT)
import Data.Text import Data.Text
import GHC.Generics (Generic) import Database.SQLite.Simple (ToRow)
import Numeric.Natural (Natural) import Database.SQLite.Simple.FromRow (FromRow)
import Web.Scotty.Trans (ScottyT, ActionT) import GHC.Generics (Generic)
import Numeric.Natural (Natural)
import Text.Blaze.Html
import Web.Scotty.Trans (ActionT, ScottyT)
type PurrApp a = ScottyT LT.Text ConfigM a type PurrApp a = ScottyT LT.Text ConfigM a
type PurrAction a = ActionT LT.Text ConfigM a type PurrAction a = ActionT LT.Text ConfigM a
type Random a = IO a
newtype ConfigM a = ConfigM newtype ConfigM a = ConfigM
{ runConfigM :: ReaderT DhallConfig IO a { runConfigM :: ReaderT DhallConfig IO a
} deriving (Applicative, Functor, Monad, MonadIO, MonadReader DhallConfig) } deriving (Applicative, Functor, Monad, MonadIO, MonadReader DhallConfig)
newtype Password = Password' String
deriving (Eq, Ord)
newtype UserSecret = UserSecret' String
deriving (Eq, Ord)
newtype GenLink = GenLink' String
deriving (Eq, Ord)
data DhallConfig = DhallConfig data DhallConfig = DhallConfig
{ environment :: String { environment :: String
, applicationHost :: String , applicationHost :: String
@ -24,3 +38,36 @@ data DhallConfig = DhallConfig
, linkLength :: Int , linkLength :: Int
, adminEmail :: String , adminEmail :: String
} deriving (Generic, Show) } deriving (Generic, Show)
data SecretEntry = SecretEntry
{ link :: T.Text
, secret :: T.Text
, date :: Integer
, life :: Integer
, views :: Integer
, maxViews :: Integer
} deriving (Show, Generic)
data Secret = Password | UserSecret
deriving (Show, Generic)
instance Show GenLink where
show (GenLink' a) = a
instance Show Password where
show (Password' a) = a
instance Show UserSecret where
show (UserSecret' a) = a
instance ToMarkup Password where
toMarkup = toMarkup . show
instance ToMarkup UserSecret where
toMarkup = toMarkup . show
instance ToMarkup Secret where
toMarkup = toMarkup . show
instance FromRow SecretEntry where
instance ToRow SecretEntry where

29
src/Feature/Generation/HTTP.hs
View File

@ -1,28 +1,25 @@
module Feature.Generation.HTTP ( routes ) where module Feature.Generation.HTTP ( routes ) where
import Core.Types import Core.Templates (renderIndex)
import Core.Templates (renderIndex) import Core.Types
import Feature.Generation.Passwords import Feature.Generation.Passwords (gibberish, oldschool,
( suggestedScheme suggestedScheme, xkcd)
, xkcd import Feature.Generation.Templates (renderGen)
, oldschool
, gibberish )
import Feature.Generation.Templates (renderGen)
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy as LT
import Control.Monad.Reader (ask, lift, liftIO) import Control.Monad.Reader (ask, lift, liftIO)
import Data.Maybe (listToMaybe) import Data.Maybe (listToMaybe)
import Web.Scotty.Trans import Prelude
import Prelude import Web.Scotty.Trans
routes :: PurrApp () routes :: PurrApp ()
routes = do routes = do
get "/gen" $ do get "/gen" $ do
genXkcd <- liftIO $ xkcd genXkcd <- liftIO $ xkcd
genOldschool <- liftIO $ oldschool genOldschool <- liftIO $ oldschool
genGibberish <- liftIO $ gibberish 12 genGibberish <- liftIO $ gibberish 12
html $ renderGen genXkcd genOldschool genGibberish html $ renderGen genXkcd genOldschool genGibberish

14
src/Feature/Generation/Links.hs
View File

@ -1,16 +1,10 @@
module Feature.Generation.Links ( genLink ) where module Feature.Generation.Links ( genLink ) where
import Core.Types import Core.Types
import Feature.Generation.Shared (rIndex, rChar, validChars) import Feature.Generation.Shared (rChar, rIndex, validChars)
import Control.Monad.Reader (ask, lift) import Control.Monad.Reader (ask, lift)
import Data.List (singleton) import Data.List (singleton)
newtype GenLink = GenLink' String
deriving (Eq, Ord)
instance Show GenLink where
show (GenLink' a) = a
-- Generates a string containing romly generated and capitalized -- Generates a string containing romly generated and capitalized
-- characters. The number of characters used is defined in the global config.dhall. -- characters. The number of characters used is defined in the global config.dhall.

54
src/Feature/Generation/Passwords.hs
View File

@ -1,36 +1,26 @@
module Feature.Generation.Passwords module Feature.Generation.Passwords
( Password ( Password
, Random
, suggestedScheme , suggestedScheme
, xkcd , xkcd
, oldschool , oldschool
, gibberish , gibberish
) where ) where
import Core.Types import Core.Types
import Feature.Generation.Shared import Feature.Generation.Shared (camelCase, rCharSym, rIndex,
( camelCase validChars, validNumbers,
, rCharSym validSymbols)
, rIndex
, validChars
, validNumbers
, validSymbols
)
import Data.List (singleton) import Data.List (singleton)
newtype Password = Password' String suggestedScheme :: Int -> Random Password
deriving (Eq, Ord) suggestedScheme i
instance Show Password where
show (Password' a) = a
suggestedScheme :: Int -> IO Password
suggestedScheme i
| i > 17 = xkcd | i > 17 = xkcd
| i > 12 = oldschool | i > 12 = oldschool
| otherwise = gibberish i | otherwise = gibberish i
xkcd :: IO Password xkcd :: Random Password
xkcd = do xkcd = do
wOne <- rCamel wOne <- rCamel
wTwo <- rCamel wTwo <- rCamel
@ -38,38 +28,38 @@ xkcd = do
wFour <- rCamel wFour <- rCamel
return $ Password' (wOne <> wTwo <> wThree <> wFour) return $ Password' (wOne <> wTwo <> wThree <> wFour)
oldschool :: IO Password oldschool :: Random Password
oldschool = do oldschool = do
wOne <- rCamel wOne <- rCamel
wTwo <- rCamel wTwo <- rCamel
nOne <- rNum nOne <- rNum
nTwo <- rNum nTwo <- rNum
nThr <- rNum nThr <- rNum
nFou <- rNum nFou <- rNum
sOne <- rSym sOne <- rSym
return return
$ Password' (wOne <> wTwo $ Password' (wOne <> wTwo
<> show nOne <> show nTwo <> show nThr <> show nFou <> show nOne <> show nTwo <> show nThr <> show nFou
<> pure sOne) <> pure sOne)
gibberish :: Int -> IO Password gibberish :: Int -> Random Password
gibberish i = go i (return "") gibberish i = go i (return "")
where where
go :: Int -> IO String -> IO Password go :: Int -> Random String -> Random Password
go 0 s = Password' <$> s go 0 s = Password' <$> s
go i s = go (i - 1) (s <> (singleton <$> rCharSym)) go i s = go (i - 1) (s <> (singleton <$> rCharSym))
rNum :: IO Int rNum :: Random Int
rNum = rIndex validNumbers rNum = rIndex validNumbers
rWord :: IO String rWord :: Random String
rWord = wordList >>= rIndex rWord = wordList >>= rIndex
rSym :: IO Char rSym :: Random Char
rSym = rIndex validSymbols rSym = rIndex validSymbols
rCamel :: IO String rCamel :: Random String
rCamel = camelCase <$> rWord rCamel = camelCase <$> rWord
wordList :: IO [String] wordList :: Random [String]
wordList = fmap lines (readFile "./src/Feature/Generation/wordlist.txt") wordList = fmap lines (readFile "./src/Feature/Generation/wordlist.txt")

10
src/Feature/Generation/Shared.hs
View File

@ -1,14 +1,14 @@
module Feature.Generation.Shared where module Feature.Generation.Shared where
import Data.Char (intToDigit, toLower, toUpper) import Data.Char (intToDigit, toLower, toUpper)
import System.Random (randomRIO) import System.Random (randomRIO)
rIndex :: [a] -> IO a rIndex :: [a] -> IO a
rIndex arr = randomRIO (0, length arr - 1) rIndex arr = randomRIO (0, length arr - 1)
>>= (\i -> return $ arr !! i) >>= (\i -> return $ arr !! i)
rCap :: Char -> IO Char rCap :: Char -> IO Char
rCap c = rIndex [True,False] >>= (\r -> return $ rCap' r c) rCap c = rIndex [True,False] >>= (\r -> return $ rCap' r c)
where where
rCap' :: Bool -> Char -> Char rCap' :: Bool -> Char -> Char
rCap' True c = toUpper c rCap' True c = toUpper c
@ -22,7 +22,7 @@ rCharSym = rIndex (validChars <> validSymbols)>>= rCap
camelCase :: [Char] -> [Char] camelCase :: [Char] -> [Char]
camelCase [] = [] camelCase [] = []
camelCase x = toUpper (head x) : map toLower (tail x) camelCase x = toUpper (head x) : map toLower (tail x)
validChars :: [Char] validChars :: [Char]
validChars = validLetters <> fmap intToDigit validNumbers validChars = validLetters <> fmap intToDigit validNumbers

18
src/Feature/Generation/Templates.hs
View File

@ -1,19 +1,19 @@
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
module Feature.Generation.Templates ( renderGen ) where module Feature.Generation.Templates ( renderGen ) where
import Core.Templates (hxVals) import Core.Templates (hxVals)
import Feature.Generation.Passwords (Password) import Feature.Generation.Passwords (Password)
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy as LT
import Text.Blaze.Html.Renderer.Text (renderHtml) import Text.Blaze.Html
import Text.Blaze.Html import Text.Blaze.Html.Renderer.Text (renderHtml)
import Text.Hamlet (shamletFile) import Text.Hamlet (shamletFile)
import Prelude import Prelude
renderGen :: Password -> Password -> Password -> LT.Text renderGen :: Password -> Password -> Password -> LT.Text
renderGen genXkcd genOldschool genGibberish = renderHtml ( $(shamletFile "./views/gen.hamlet") ) renderGen genXkcd genOldschool genGibberish = renderHtml ( $(shamletFile "./views/gen.hamlet") )

31
src/Feature/Sharing/HTTP.hs
View File

@ -1,26 +1,25 @@
module Feature.Sharing.HTTP ( routes ) where module Feature.Sharing.HTTP ( routes ) where
import Core.SQLite (confLinkLength) import Core.SQLite (confLinkLength)
import Core.Types import Core.Templates (renderIndex)
import Core.Templates (renderIndex) import Core.Types
import Feature.Generation.Links (genLink) import Feature.Generation.Links (genLink)
import Feature.Sharing.SQLite (findByLink, insertNewSecret) import Feature.Sharing.SQLite (findByLink, insertNewSecret)
import Feature.Sharing.Templates (renderPw) import Feature.Sharing.Templates (renderPw)
import Feature.Sharing.Types
import Control.Monad.Reader (ask, lift, liftIO) import Control.Monad.Reader (ask, lift, liftIO)
import Data.Maybe (listToMaybe) import Data.List.Split (splitOn)
import Data.List.Split (splitOn) import Data.Maybe (listToMaybe)
import Web.Scotty.Trans import Prelude
import Prelude import Web.Scotty.Trans
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy as LT
routes :: PurrApp () routes :: PurrApp ()
routes = do routes = do
get "/pw/:id" $ do get "/pw/:id" $ do
reqId <- param "id" reqId <- param "id"
@ -32,7 +31,7 @@ routes = do
res <- findByLink reqId res <- findByLink reqId
html $ renderPw (last $ splitOn "/" reqId) res html $ renderPw (last $ splitOn "/" reqId) res
post "/new" $ do post "/new" $ do
reqSecret <- param "newSec" reqSecret <- param "newSec"
reqDur <- param "newSecDuration" reqDur <- param "newSecDuration"
reqViews <- param "newSecViews" reqViews <- param "newSecViews"

45
src/Feature/Sharing/SQLite.hs
View File

@ -1,22 +1,21 @@
module Feature.Sharing.SQLite where module Feature.Sharing.SQLite where
import Core.Types import Core.SQLite
import Core.SQLite import Core.Types
import Feature.Generation.Passwords (Password) import Feature.Generation.Passwords (Password)
import Feature.Sharing.Types
import Control.Monad.Reader (ask, lift, liftIO) import Control.Monad.Reader (ask, lift, liftIO)
import Crypto.Simple.CBC (encrypt, decrypt) import Crypto.Simple.CBC (decrypt, encrypt)
import Data.Maybe (listToMaybe) import Data.List.Split (splitOn)
import Data.Time.Clock.POSIX (getPOSIXTime) import Data.Maybe (listToMaybe)
import Data.List.Split (splitOn) import Data.Time.Clock.POSIX (getPOSIXTime)
import Database.SQLite.Simple import Database.SQLite.Simple
import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Char8 as B
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.Encoding as ET import qualified Data.Text.Encoding as ET
import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy as LT
findByLink :: String -> PurrAction (Maybe T.Text) findByLink :: String -> PurrAction (Maybe T.Text)
findByLink link = do findByLink link = do
@ -34,7 +33,7 @@ insertNewSecret sec life link maxViews = do
encSec <- liftIO $ encryptSecret key sec encSec <- liftIO $ encryptSecret key sec
conn <- liftIO $ open db conn <- liftIO $ open db
time <- liftIO $ epochTime time <- liftIO $ epochTime
liftIO $ execute conn liftIO $ execute conn
"INSERT INTO pws (link, secret, date, life, views, maxViews) VALUES (?, ?, ?, ?, ?, ?)" "INSERT INTO pws (link, secret, date, life, views, maxViews) VALUES (?, ?, ?, ?, ?, ?)"
(SecretEntry link (encodeSecret encSec) time life 0 maxViews) (SecretEntry link (encodeSecret encSec) time life 0 maxViews)
liftIO $ close conn liftIO $ close conn
@ -44,9 +43,9 @@ readEncryptedSecret key sec = do
db <- dbPath db <- dbPath
liftIO $ incViews sec db liftIO $ incViews sec db
delete <- liftIO $ deleteExpiredSecret sec db delete <- liftIO $ deleteExpiredSecret sec db
decKey <- liftIO ( sequence decKey <- liftIO ( sequence
$ decryptSecret key $ decryptSecret key
<$> decodeSecret <$> decodeSecret
<$> listToMaybe sec ) <$> listToMaybe sec )
if (delete) if (delete)
then return Nothing then return Nothing
@ -66,18 +65,18 @@ deleteExpiredSecret :: [SecretEntry] -> String -> IO Bool
deleteExpiredSecret [] _ = return False deleteExpiredSecret [] _ = return False
deleteExpiredSecret (sec : _) db = do deleteExpiredSecret (sec : _) db = do
time <- liftIO $ epochTime time <- liftIO $ epochTime
if ((date sec) + ((life sec) * 86400) < time) || (views sec >= maxViews sec) if ((date sec) + ((life sec) * 86400) < time) || (views sec >= maxViews sec)
then deleteSec sec db then deleteSec sec db
else return False else return False
where where
deleteSec :: SecretEntry -> String -> IO Bool deleteSec :: SecretEntry -> String -> IO Bool
deleteSec sec db = do deleteSec sec db = do
conn <- liftIO $ open db conn <- liftIO $ open db
liftIO $ execute conn liftIO $ execute conn
"DELETE FROM pws WHERE link = ?" (Only (link sec)) "DELETE FROM pws WHERE link = ?" (Only (link sec))
liftIO $ close conn liftIO $ close conn
return True return True
encodeSecret :: B.ByteString -> T.Text encodeSecret :: B.ByteString -> T.Text
encodeSecret b = ET.decodeUtf8 $ B64.encode b encodeSecret b = ET.decodeUtf8 $ B64.encode b
@ -88,7 +87,7 @@ encryptSecret :: String -> T.Text -> IO B.ByteString
encryptSecret k s = encrypt (B.pack k) (ET.encodeUtf8 s) encryptSecret k s = encrypt (B.pack k) (ET.encodeUtf8 s)
decryptSecret :: String -> B.ByteString -> IO B.ByteString decryptSecret :: String -> B.ByteString -> IO B.ByteString
decryptSecret k b = decrypt (B.pack k) b decryptSecret k b = decrypt (B.pack k) b
epochTime :: IO Integer epochTime :: IO Integer
epochTime = fmap round getPOSIXTime epochTime = fmap round getPOSIXTime

16
src/Feature/Sharing/Templates.hs
View File

@ -1,16 +1,18 @@
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
module Feature.Sharing.Templates ( renderPw ) where module Feature.Sharing.Templates ( renderPw ) where
import qualified Data.Text as T import Core.Types
import qualified Data.Text.Lazy as LT
import Text.Blaze.Html.Renderer.Text (renderHtml) import qualified Data.Text as T
import Text.Blaze.Html import qualified Data.Text.Lazy as LT
import Text.Hamlet (shamletFile)
import Prelude import Text.Blaze.Html
import Text.Blaze.Html.Renderer.Text (renderHtml)
import Text.Hamlet (shamletFile)
import Prelude
renderPw :: String -> Maybe T.Text -> LT.Text renderPw :: String -> Maybe T.Text -> LT.Text
renderPw link password = renderHtml ( $(shamletFile "./views/pw.hamlet") ) renderPw link password = renderHtml ( $(shamletFile "./views/pw.hamlet") )

22
src/Feature/Sharing/Types.hs
View File

@ -1,22 +0,0 @@
module Feature.Sharing.Types where
import Data.Map.Strict (Map)
import Data.Typeable (Typeable)
import GHC.Generics
import Database.SQLite.Simple
import Database.SQLite.Simple.FromRow
import qualified Data.Text as T
data SecretEntry = SecretEntry
{ link :: T.Text
, secret :: T.Text
, date :: Integer
, life :: Integer
, views :: Integer
, maxViews :: Integer
} deriving (Show, Generic)
instance FromRow SecretEntry where
instance ToRow SecretEntry where

14
src/Lib.hs
View File

@ -1,14 +1,14 @@
module Lib ( main ) where module Lib ( main ) where
import qualified Core.Configuration as Configuration import qualified Core.Configuration as Configuration
import qualified Core.HTTP as HTTP import qualified Core.HTTP as HTTP
import qualified Core.SQLite as DB import qualified Core.SQLite as DB
import Core.Types import Core.Types
import Control.Monad.Reader (lift, liftIO, runReaderT) import Control.Monad.Reader (lift, liftIO, runReaderT)
import GHC.Natural (popCountNatural) import GHC.Natural (popCountNatural)
import Prelude hiding (id) import Prelude hiding (id)
import Web.Scotty.Trans (scottyT) import Web.Scotty.Trans (scottyT)
main :: IO () main :: IO ()
main = do main = do