commit cb45c4ce1d5b38881295ffc1a8532681e862e1c4
parent 84c49319a691ea943f9df0aa70b231753ef2360e
Author: James Eversole <james@eversole.co>
Date: Tue, 10 Jan 2023 21:53:10 -0600
Start formatting with stylish-haskell. Start refactoring for clearer types.
Diffstat:
16 files changed, 185 insertions(+), 180 deletions(-)
diff --git a/Purr.cabal b/Purr.cabal
@@ -32,7 +32,6 @@ library
Feature.Sharing.HTTP
Feature.Sharing.SQLite
Feature.Sharing.Templates
- Feature.Sharing.Types
Lib
other-modules:
Paths_Purr
diff --git a/src/Core/Configuration.hs b/src/Core/Configuration.hs
@@ -1,8 +1,8 @@
module Core.Configuration ( main ) where
-import Core.Types
+import Core.Types
-import Dhall
+import Dhall
instance FromDhall DhallConfig
diff --git a/src/Core/HTTP.hs b/src/Core/HTTP.hs
@@ -1,16 +1,16 @@
module Core.HTTP ( app ) where
-import Core.Types
+import Core.Types
-import Core.Templates (renderIndex, renderStyle)
-import Feature.Sharing.HTTP as Sharing
-import Feature.Generation.HTTP as Generation
+import Core.Templates (renderIndex, renderStyle)
+import Feature.Generation.HTTP as Generation
+import Feature.Sharing.HTTP as Sharing
-import Control.Monad.Reader (ask, lift)
-import Data.Maybe (Maybe (Nothing))
-import Network.Wai.Middleware.RequestLogger (logStdoutDev)
-import Network.Wai.Middleware.Static
-import Web.Scotty.Trans
+import Control.Monad.Reader (ask, lift)
+import Data.Maybe (Maybe (Nothing))
+import Network.Wai.Middleware.RequestLogger (logStdoutDev)
+import Network.Wai.Middleware.Static
+import Web.Scotty.Trans
app :: PurrApp ()
app = do
diff --git a/src/Core/SQLite.hs b/src/Core/SQLite.hs
@@ -1,17 +1,17 @@
module Core.SQLite where
-import Core.Types
+import Core.Types
-import Control.Monad.Reader (ask, lift, liftIO)
-import Database.SQLite.Simple
-import Database.SQLite.Simple.FromRow
+import Control.Monad.Reader (ask, lift, liftIO)
+import Database.SQLite.Simple
+import Database.SQLite.Simple.FromRow
-import qualified Data.Text as T
+import qualified Data.Text as T
main :: String -> IO ()
-main db = do
+main db = do
conn <- open db
- execute_ conn
+ execute_ conn
"CREATE TABLE IF NOT EXISTS pws\
\ (link TEXT PRIMARY KEY,\
\ secret TEXT,\
diff --git a/src/Core/Templates.hs b/src/Core/Templates.hs
@@ -1,17 +1,17 @@
-{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
module Core.Templates ( renderIndex, renderStyle, hxVals ) where
-import Text.Blaze.Html.Renderer.Text (renderHtml)
-import Text.Blaze.Html
-import Text.Cassius (cassiusFile, renderCss)
-import Text.Hamlet (shamletFile)
+import Text.Blaze.Html
+import Text.Blaze.Html.Renderer.Text (renderHtml)
+import Text.Cassius (cassiusFile, renderCss)
+import Text.Hamlet (shamletFile)
-import qualified Data.Text as T
-import qualified Data.Text.Lazy as LT
+import qualified Data.Text as T
+import qualified Data.Text.Lazy as LT
-import Prelude
+import Prelude
renderIndex :: String -> String -> LT.Text
renderIndex link email = renderHtml ( $(shamletFile "./views/index.hamlet") )
diff --git a/src/Core/Types.hs b/src/Core/Types.hs
@@ -1,20 +1,34 @@
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 Data.Text
-import GHC.Generics (Generic)
-import Numeric.Natural (Natural)
-import Web.Scotty.Trans (ScottyT, ActionT)
+import Control.Monad.Reader (MonadIO, MonadReader, ReaderT)
+import Data.Text
+import Database.SQLite.Simple (ToRow)
+import Database.SQLite.Simple.FromRow (FromRow)
+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 PurrAction a = ActionT LT.Text ConfigM a
+type Random a = IO a
newtype ConfigM a = ConfigM
{ runConfigM :: ReaderT DhallConfig IO a
} 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
{ environment :: String
, applicationHost :: String
@@ -24,3 +38,36 @@ data DhallConfig = DhallConfig
, linkLength :: Int
, adminEmail :: String
} 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
diff --git a/src/Feature/Generation/HTTP.hs b/src/Feature/Generation/HTTP.hs
@@ -1,28 +1,25 @@
module Feature.Generation.HTTP ( routes ) where
-import Core.Types
-import Core.Templates (renderIndex)
+import Core.Templates (renderIndex)
+import Core.Types
-import Feature.Generation.Passwords
- ( suggestedScheme
- , xkcd
- , oldschool
- , gibberish )
-import Feature.Generation.Templates (renderGen)
+import Feature.Generation.Passwords (gibberish, oldschool,
+ suggestedScheme, xkcd)
+import Feature.Generation.Templates (renderGen)
-import qualified Data.Text as T
-import qualified Data.Text.Lazy as LT
+import qualified Data.Text as T
+import qualified Data.Text.Lazy as LT
-import Control.Monad.Reader (ask, lift, liftIO)
-import Data.Maybe (listToMaybe)
-import Web.Scotty.Trans
-import Prelude
+import Control.Monad.Reader (ask, lift, liftIO)
+import Data.Maybe (listToMaybe)
+import Prelude
+import Web.Scotty.Trans
routes :: PurrApp ()
-routes = do
+routes = do
get "/gen" $ do
genXkcd <- liftIO $ xkcd
genOldschool <- liftIO $ oldschool
genGibberish <- liftIO $ gibberish 12
- html $ renderGen genXkcd genOldschool genGibberish
+ html $ renderGen genXkcd genOldschool genGibberish
diff --git a/src/Feature/Generation/Links.hs b/src/Feature/Generation/Links.hs
@@ -1,16 +1,10 @@
module Feature.Generation.Links ( genLink ) where
-import Core.Types
-import Feature.Generation.Shared (rIndex, rChar, validChars)
+import Core.Types
+import Feature.Generation.Shared (rChar, rIndex, validChars)
-import Control.Monad.Reader (ask, lift)
-import Data.List (singleton)
-
-newtype GenLink = GenLink' String
- deriving (Eq, Ord)
-
-instance Show GenLink where
- show (GenLink' a) = a
+import Control.Monad.Reader (ask, lift)
+import Data.List (singleton)
-- Generates a string containing romly generated and capitalized
-- characters. The number of characters used is defined in the global config.dhall.
diff --git a/src/Feature/Generation/Passwords.hs b/src/Feature/Generation/Passwords.hs
@@ -1,36 +1,26 @@
-module Feature.Generation.Passwords
+module Feature.Generation.Passwords
( Password
+ , Random
, suggestedScheme
, xkcd
, oldschool
- , gibberish
+ , gibberish
) where
-import Core.Types
-import Feature.Generation.Shared
- ( camelCase
- , rCharSym
- , rIndex
- , validChars
- , validNumbers
- , validSymbols
- )
+import Core.Types
+import Feature.Generation.Shared (camelCase, rCharSym, rIndex,
+ validChars, validNumbers,
+ validSymbols)
-import Data.List (singleton)
+import Data.List (singleton)
-newtype Password = Password' String
- deriving (Eq, Ord)
-
-instance Show Password where
- show (Password' a) = a
-
-suggestedScheme :: Int -> IO Password
-suggestedScheme i
+suggestedScheme :: Int -> Random Password
+suggestedScheme i
| i > 17 = xkcd
| i > 12 = oldschool
| otherwise = gibberish i
-xkcd :: IO Password
+xkcd :: Random Password
xkcd = do
wOne <- rCamel
wTwo <- rCamel
@@ -38,38 +28,38 @@ xkcd = do
wFour <- rCamel
return $ Password' (wOne <> wTwo <> wThree <> wFour)
-oldschool :: IO Password
+oldschool :: Random Password
oldschool = do
wOne <- rCamel
wTwo <- rCamel
nOne <- rNum
- nTwo <- rNum
+ nTwo <- rNum
nThr <- rNum
nFou <- rNum
sOne <- rSym
- return
- $ Password' (wOne <> wTwo
+ return
+ $ Password' (wOne <> wTwo
<> show nOne <> show nTwo <> show nThr <> show nFou
<> pure sOne)
-gibberish :: Int -> IO Password
+gibberish :: Int -> Random Password
gibberish i = go i (return "")
where
- go :: Int -> IO String -> IO Password
+ go :: Int -> Random String -> Random Password
go 0 s = Password' <$> s
go i s = go (i - 1) (s <> (singleton <$> rCharSym))
-rNum :: IO Int
+rNum :: Random Int
rNum = rIndex validNumbers
-rWord :: IO String
+rWord :: Random String
rWord = wordList >>= rIndex
-rSym :: IO Char
+rSym :: Random Char
rSym = rIndex validSymbols
-rCamel :: IO String
+rCamel :: Random String
rCamel = camelCase <$> rWord
-wordList :: IO [String]
+wordList :: Random [String]
wordList = fmap lines (readFile "./src/Feature/Generation/wordlist.txt")
diff --git a/src/Feature/Generation/Shared.hs b/src/Feature/Generation/Shared.hs
@@ -1,14 +1,14 @@
module Feature.Generation.Shared where
-import Data.Char (intToDigit, toLower, toUpper)
-import System.Random (randomRIO)
+import Data.Char (intToDigit, toLower, toUpper)
+import System.Random (randomRIO)
rIndex :: [a] -> IO a
-rIndex arr = randomRIO (0, length arr - 1)
+rIndex arr = randomRIO (0, length arr - 1)
>>= (\i -> return $ arr !! i)
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
rCap' :: Bool -> Char -> Char
rCap' True c = toUpper c
@@ -22,7 +22,7 @@ rCharSym = rIndex (validChars <> validSymbols)>>= rCap
camelCase :: [Char] -> [Char]
camelCase [] = []
-camelCase x = toUpper (head x) : map toLower (tail x)
+camelCase x = toUpper (head x) : map toLower (tail x)
validChars :: [Char]
validChars = validLetters <> fmap intToDigit validNumbers
diff --git a/src/Feature/Generation/Templates.hs b/src/Feature/Generation/Templates.hs
@@ -1,19 +1,19 @@
-{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
module Feature.Generation.Templates ( renderGen ) where
-import Core.Templates (hxVals)
-import Feature.Generation.Passwords (Password)
+import Core.Templates (hxVals)
+import Feature.Generation.Passwords (Password)
-import qualified Data.Text as T
-import qualified Data.Text.Lazy as LT
+import qualified Data.Text as T
+import qualified Data.Text.Lazy as LT
-import Text.Blaze.Html.Renderer.Text (renderHtml)
-import Text.Blaze.Html
-import Text.Hamlet (shamletFile)
+import Text.Blaze.Html
+import Text.Blaze.Html.Renderer.Text (renderHtml)
+import Text.Hamlet (shamletFile)
-import Prelude
+import Prelude
renderGen :: Password -> Password -> Password -> LT.Text
renderGen genXkcd genOldschool genGibberish = renderHtml ( $(shamletFile "./views/gen.hamlet") )
diff --git a/src/Feature/Sharing/HTTP.hs b/src/Feature/Sharing/HTTP.hs
@@ -1,26 +1,25 @@
module Feature.Sharing.HTTP ( routes ) where
-import Core.SQLite (confLinkLength)
-import Core.Types
-import Core.Templates (renderIndex)
+import Core.SQLite (confLinkLength)
+import Core.Templates (renderIndex)
+import Core.Types
-import Feature.Generation.Links (genLink)
-import Feature.Sharing.SQLite (findByLink, insertNewSecret)
-import Feature.Sharing.Templates (renderPw)
-import Feature.Sharing.Types
+import Feature.Generation.Links (genLink)
+import Feature.Sharing.SQLite (findByLink, insertNewSecret)
+import Feature.Sharing.Templates (renderPw)
-import Control.Monad.Reader (ask, lift, liftIO)
-import Data.Maybe (listToMaybe)
-import Data.List.Split (splitOn)
-import Web.Scotty.Trans
-import Prelude
+import Control.Monad.Reader (ask, lift, liftIO)
+import Data.List.Split (splitOn)
+import Data.Maybe (listToMaybe)
+import Prelude
+import Web.Scotty.Trans
-import qualified Data.Text as T
-import qualified Data.Text.Lazy as LT
+import qualified Data.Text as T
+import qualified Data.Text.Lazy as LT
routes :: PurrApp ()
-routes = do
+routes = do
get "/pw/:id" $ do
reqId <- param "id"
@@ -32,7 +31,7 @@ routes = do
res <- findByLink reqId
html $ renderPw (last $ splitOn "/" reqId) res
- post "/new" $ do
+ post "/new" $ do
reqSecret <- param "newSec"
reqDur <- param "newSecDuration"
reqViews <- param "newSecViews"
diff --git a/src/Feature/Sharing/SQLite.hs b/src/Feature/Sharing/SQLite.hs
@@ -1,22 +1,21 @@
module Feature.Sharing.SQLite where
-import Core.Types
-import Core.SQLite
-import Feature.Generation.Passwords (Password)
-import Feature.Sharing.Types
+import Core.SQLite
+import Core.Types
+import Feature.Generation.Passwords (Password)
-import Control.Monad.Reader (ask, lift, liftIO)
-import Crypto.Simple.CBC (encrypt, decrypt)
-import Data.Maybe (listToMaybe)
-import Data.Time.Clock.POSIX (getPOSIXTime)
-import Data.List.Split (splitOn)
-import Database.SQLite.Simple
+import Control.Monad.Reader (ask, lift, liftIO)
+import Crypto.Simple.CBC (decrypt, encrypt)
+import Data.List.Split (splitOn)
+import Data.Maybe (listToMaybe)
+import Data.Time.Clock.POSIX (getPOSIXTime)
+import Database.SQLite.Simple
-import qualified Data.ByteString.Base64 as B64
-import qualified Data.ByteString.Char8 as B
-import qualified Data.Text as T
-import qualified Data.Text.Encoding as ET
-import qualified Data.Text.Lazy as LT
+import qualified Data.ByteString.Base64 as B64
+import qualified Data.ByteString.Char8 as B
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as ET
+import qualified Data.Text.Lazy as LT
findByLink :: String -> PurrAction (Maybe T.Text)
findByLink link = do
@@ -34,7 +33,7 @@ insertNewSecret sec life link maxViews = do
encSec <- liftIO $ encryptSecret key sec
conn <- liftIO $ open db
time <- liftIO $ epochTime
- liftIO $ execute conn
+ liftIO $ execute conn
"INSERT INTO pws (link, secret, date, life, views, maxViews) VALUES (?, ?, ?, ?, ?, ?)"
(SecretEntry link (encodeSecret encSec) time life 0 maxViews)
liftIO $ close conn
@@ -44,9 +43,9 @@ readEncryptedSecret key sec = do
db <- dbPath
liftIO $ incViews sec db
delete <- liftIO $ deleteExpiredSecret sec db
- decKey <- liftIO ( sequence
- $ decryptSecret key
- <$> decodeSecret
+ decKey <- liftIO ( sequence
+ $ decryptSecret key
+ <$> decodeSecret
<$> listToMaybe sec )
if (delete)
then return Nothing
@@ -66,18 +65,18 @@ deleteExpiredSecret :: [SecretEntry] -> String -> IO Bool
deleteExpiredSecret [] _ = return False
deleteExpiredSecret (sec : _) db = do
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
else return False
where
deleteSec :: SecretEntry -> String -> IO Bool
deleteSec sec db = do
conn <- liftIO $ open db
- liftIO $ execute conn
+ liftIO $ execute conn
"DELETE FROM pws WHERE link = ?" (Only (link sec))
liftIO $ close conn
return True
-
+
encodeSecret :: B.ByteString -> T.Text
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)
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 = fmap round getPOSIXTime
diff --git a/src/Feature/Sharing/Templates.hs b/src/Feature/Sharing/Templates.hs
@@ -1,16 +1,18 @@
-{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
module Feature.Sharing.Templates ( renderPw ) where
-import qualified Data.Text as T
-import qualified Data.Text.Lazy as LT
+import Core.Types
-import Text.Blaze.Html.Renderer.Text (renderHtml)
-import Text.Blaze.Html
-import Text.Hamlet (shamletFile)
+import qualified Data.Text as T
+import qualified Data.Text.Lazy as LT
-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 link password = renderHtml ( $(shamletFile "./views/pw.hamlet") )
diff --git a/src/Feature/Sharing/Types.hs b/src/Feature/Sharing/Types.hs
@@ -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
diff --git a/src/Lib.hs b/src/Lib.hs
@@ -1,14 +1,14 @@
module Lib ( main ) where
-import qualified Core.Configuration as Configuration
-import qualified Core.HTTP as HTTP
-import qualified Core.SQLite as DB
+import qualified Core.Configuration as Configuration
+import qualified Core.HTTP as HTTP
+import qualified Core.SQLite as DB
import Core.Types
-import Control.Monad.Reader (lift, liftIO, runReaderT)
-import GHC.Natural (popCountNatural)
-import Prelude hiding (id)
-import Web.Scotty.Trans (scottyT)
+import Control.Monad.Reader (lift, liftIO, runReaderT)
+import GHC.Natural (popCountNatural)
+import Prelude hiding (id)
+import Web.Scotty.Trans (scottyT)
main :: IO ()
main = do
