From cb45c4ce1d5b38881295ffc1a8532681e862e1c4 Mon Sep 17 00:00:00 2001 From: James Eversole Date: Tue, 10 Jan 2023 21:53:10 -0600 Subject: [PATCH] Start formatting with stylish-haskell. Start refactoring for clearer types. --- Purr.cabal | 1 - src/Core/Configuration.hs | 4 +- src/Core/HTTP.hs | 18 ++++----- src/Core/SQLite.hs | 14 +++---- src/Core/Templates.hs | 16 ++++---- src/Core/Types.hs | 59 ++++++++++++++++++++++++++--- src/Feature/Generation/HTTP.hs | 29 +++++++------- src/Feature/Generation/Links.hs | 14 ++----- src/Feature/Generation/Passwords.hs | 54 +++++++++++--------------- src/Feature/Generation/Shared.hs | 10 ++--- src/Feature/Generation/Templates.hs | 18 ++++----- src/Feature/Sharing/HTTP.hs | 31 ++++++++------- src/Feature/Sharing/SQLite.hs | 45 +++++++++++----------- src/Feature/Sharing/Templates.hs | 16 ++++---- src/Feature/Sharing/Types.hs | 22 ----------- src/Lib.hs | 14 +++---- 16 files changed, 185 insertions(+), 180 deletions(-) delete mode 100644 src/Feature/Sharing/Types.hs diff --git a/Purr.cabal b/Purr.cabal index fcdeabc..c2c85f4 100644 --- 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 index fc5b26e..d53493e 100644 --- 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 index c1011c6..a853762 100644 --- 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 index 86eea60..f4f3dc8 100644 --- 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 index 71eeef5..96bbcb2 100644 --- 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 index 5a2061e..77252b2 100644 --- 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 index fefa4c4..1c738a5 100644 --- 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 index b9dc32a..856de1f 100644 --- 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 index 13b42ff..d06833d 100644 --- 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 index 3483c0d..c28d48e 100644 --- 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 index 41343e3..31c66e0 100644 --- 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 index cf29d09..95115e3 100644 --- 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 index 5d69432..af206ab 100644 --- 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 index a5b92d2..c155a6a 100644 --- 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 deleted file mode 100644 index ae7db64..0000000 --- a/src/Feature/Sharing/Types.hs +++ /dev/null @@ -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 index 7946d48..cf0d20e 100644 --- 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