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
Download Patch File Download Diff File Expand all files Collapse all files

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

@ -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

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

@ -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.

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

@ -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")

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

@ -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

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

@ -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") )

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

@ -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"

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

@ -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

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

@ -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") )

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