diff --git a/examples/config.dhall b/examples/config.dhall index 712f79d..d07c402 100644 --- a/examples/config.dhall +++ b/examples/config.dhall @@ -12,4 +12,5 @@ , dbFile = "data/Purr.sqlite" , dbKey = "REPLACEME!!!!!" , linkLength = +24 +, adminEmail = "james@eversole.co" } diff --git a/src/Core/HTTP.hs b/src/Core/HTTP.hs index a7eba7d..c1011c6 100644 --- a/src/Core/HTTP.hs +++ b/src/Core/HTTP.hs @@ -6,6 +6,7 @@ import Core.Templates (renderIndex, renderStyle) import Feature.Sharing.HTTP as Sharing import Feature.Generation.HTTP as Generation +import Control.Monad.Reader (ask, lift) import Data.Maybe (Maybe (Nothing)) import Network.Wai.Middleware.RequestLogger (logStdoutDev) import Network.Wai.Middleware.Static @@ -19,7 +20,8 @@ app = do -- Core Routes get "/" $ do - html $ renderIndex "/" + conf <- lift ask + html $ renderIndex "/" (adminEmail conf) get "/style.css" $ do setHeader "Content-Type" "text/css" diff --git a/src/Core/SQLite.hs b/src/Core/SQLite.hs index 081cf85..86eea60 100644 --- a/src/Core/SQLite.hs +++ b/src/Core/SQLite.hs @@ -22,11 +22,10 @@ main db = do close conn dbPath :: PurrAction String -dbPath = do - conf <- lift ask - return $ dbFile conf +dbPath = lift ask >>= (\a -> return $ dbFile a) encKey :: PurrAction String -encKey = do - conf <- lift ask - return $ dbKey conf +encKey = lift ask >>= (\a -> return $ dbKey a) + +confLinkLength :: PurrAction Int +confLinkLength = lift ask >>= (\a -> return $ linkLength a) diff --git a/src/Core/Templates.hs b/src/Core/Templates.hs index 859d7f9..71eeef5 100644 --- a/src/Core/Templates.hs +++ b/src/Core/Templates.hs @@ -13,8 +13,8 @@ import qualified Data.Text.Lazy as LT import Prelude -renderIndex :: String -> LT.Text -renderIndex link = renderHtml ( $(shamletFile "./views/index.hamlet") ) +renderIndex :: String -> String -> LT.Text +renderIndex link email = renderHtml ( $(shamletFile "./views/index.hamlet") ) where hsUserLink = hxVals "userLink" link diff --git a/src/Core/Types.hs b/src/Core/Types.hs index 75ffa95..5a2061e 100644 --- a/src/Core/Types.hs +++ b/src/Core/Types.hs @@ -22,4 +22,5 @@ data DhallConfig = DhallConfig , dbFile :: String , dbKey :: String , linkLength :: Int + , adminEmail :: String } deriving (Generic, Show) diff --git a/src/Feature/Generation/HTTP.hs b/src/Feature/Generation/HTTP.hs index 74ddd0d..fefa4c4 100644 --- a/src/Feature/Generation/HTTP.hs +++ b/src/Feature/Generation/HTTP.hs @@ -3,7 +3,11 @@ module Feature.Generation.HTTP ( routes ) where import Core.Types import Core.Templates (renderIndex) -import Feature.Generation.Passwords (suggestedScheme) +import Feature.Generation.Passwords + ( suggestedScheme + , xkcd + , oldschool + , gibberish ) import Feature.Generation.Templates (renderGen) import qualified Data.Text as T @@ -18,5 +22,7 @@ routes :: PurrApp () routes = do get "/gen" $ do - genPw <- liftIO $ suggestedScheme 24 - html $ renderGen genPw + genXkcd <- liftIO $ xkcd + genOldschool <- liftIO $ oldschool + genGibberish <- liftIO $ gibberish 12 + html $ renderGen genXkcd genOldschool genGibberish diff --git a/src/Feature/Generation/Links.hs b/src/Feature/Generation/Links.hs index 359bfa4..b9dc32a 100644 --- a/src/Feature/Generation/Links.hs +++ b/src/Feature/Generation/Links.hs @@ -1,43 +1,21 @@ module Feature.Generation.Links ( genLink ) where import Core.Types -import Feature.Generation.Shared (rIndex, validChars) +import Feature.Generation.Shared (rIndex, rChar, validChars) -import Control.Monad.Reader (ask, lift, liftIO) -import Data.Char (toLower, toUpper) -import System.IO -import System.Random +import Control.Monad.Reader (ask, lift) +import Data.List (singleton) --- Generates a string containing randomly generated and capitalized +newtype GenLink = GenLink' String + deriving (Eq, Ord) + +instance Show GenLink where + show (GenLink' a) = a + +-- Generates a string containing romly generated and capitalized -- characters. The number of characters used is defined in the global config.dhall. -genLink :: PurrAction String -genLink = do - linkLength <- confLinkLength - genLink' linkLength "" +genLink :: Int -> IO GenLink +genLink linkLength = genLink' linkLength (return "") where - genLink' 0 cs = return cs - genLink' d cs = do - res <- liftIO $ randChar - fin <- liftIO $ randCapitalization res - genLink' (d - 1) (cs <> (fin:[])) - -randChar :: IO Char -randChar = rIndex validChars - -randCapitalization :: Char -> IO Char -randCapitalization c = do - capRand <- randomRIO (0,1) - return $ go capRand c - where - go :: Int -> Char -> Char - go r c - | r == 0 = toLower c - | r == 1 = toUpper c - | otherwise = c - --- Helper function in our PurrAction monad transformer stack to read --- the desired length for generated links. -confLinkLength :: PurrAction Int -confLinkLength = do - conf <- lift ask - return $ linkLength conf + genLink' 0 cs = GenLink' <$> cs + genLink' d cs = genLink' (d - 1) (cs <> (singleton <$> rChar)) diff --git a/src/Feature/Generation/Passwords.hs b/src/Feature/Generation/Passwords.hs index d160682..13b42ff 100644 --- a/src/Feature/Generation/Passwords.hs +++ b/src/Feature/Generation/Passwords.hs @@ -1,47 +1,75 @@ -module Feature.Generation.Passwords where +module Feature.Generation.Passwords + ( Password + , suggestedScheme + , xkcd + , oldschool + , gibberish + ) where import Core.Types -import Feature.Generation.Shared (rIndex, validChars) +import Feature.Generation.Shared + ( camelCase + , rCharSym + , rIndex + , validChars + , validNumbers + , validSymbols + ) -import Control.Monad.Reader (ask, lift, liftIO) -import Data.Char (toLower, toUpper) import Data.List (singleton) -import System.IO -import System.Random -camelCase :: [Char] -> [Char] -camelCase [] = [] -camelCase x = toUpper (head x) : map toLower (tail x) +newtype Password = Password' String + deriving (Eq, Ord) --- suggestedScheme and its helpers xkcd, oldschool, and gibberish are TODO. -suggestedScheme :: Int -> IO String +instance Show Password where + show (Password' a) = a + +suggestedScheme :: Int -> IO Password suggestedScheme i - | i > 23 = xkcd i - | i > 12 = oldschool i + | i > 17 = xkcd + | i > 12 = oldschool | otherwise = gibberish i -xkcd :: Int -> IO String -xkcd i = do - wOne <- randomCamel - wTwo <- randomCamel - wThree <- randomCamel - wFour <- randomCamel - return $ wOne <> wTwo <> wThree <> wFour +xkcd :: IO Password +xkcd = do + wOne <- rCamel + wTwo <- rCamel + wThree <- rCamel + wFour <- rCamel + return $ Password' (wOne <> wTwo <> wThree <> wFour) -oldschool :: Int -> IO String -oldschool i = do - wOne <- randomWord - wTwo <- randomWord - return $ wOne <> wTwo +oldschool :: IO Password +oldschool = do + wOne <- rCamel + wTwo <- rCamel + nOne <- rNum + nTwo <- rNum + nThr <- rNum + nFou <- rNum + sOne <- rSym + return + $ Password' (wOne <> wTwo + <> show nOne <> show nTwo <> show nThr <> show nFou + <> pure sOne) -gibberish :: Int -> IO String -gibberish i = return "mf98sgs7bgg%#" +gibberish :: Int -> IO Password +gibberish i = go i (return "") + where + go :: Int -> IO String -> IO Password + go 0 s = Password' <$> s + go i s = go (i - 1) (s <> (singleton <$> rCharSym)) + +rNum :: IO Int +rNum = rIndex validNumbers + +rWord :: IO String +rWord = wordList >>= rIndex + +rSym :: IO Char +rSym = rIndex validSymbols + +rCamel :: IO String +rCamel = camelCase <$> rWord wordList :: IO [String] wordList = fmap lines (readFile "./src/Feature/Generation/wordlist.txt") - -randomWord :: IO String -randomWord = wordList >>= rIndex - -randomCamel :: IO String -randomCamel = camelCase <$> randomWord diff --git a/src/Feature/Generation/Shared.hs b/src/Feature/Generation/Shared.hs index cb9cc9f..3483c0d 100644 --- a/src/Feature/Generation/Shared.hs +++ b/src/Feature/Generation/Shared.hs @@ -1,20 +1,37 @@ module Feature.Generation.Shared where +import Data.Char (intToDigit, toLower, toUpper) import System.Random (randomRIO) rIndex :: [a] -> IO a -rIndex arr = do - i <- randomRIO (0, length arr - 1) - return $ arr !! i +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) + where + rCap' :: Bool -> Char -> Char + rCap' True c = toUpper c + rCap' False c = toLower c + +rChar :: IO Char +rChar = rIndex validChars >>= rCap + +rCharSym :: IO Char +rCharSym = rIndex (validChars <> validSymbols)>>= rCap + +camelCase :: [Char] -> [Char] +camelCase [] = [] +camelCase x = toUpper (head x) : map toLower (tail x) --- Defines the valid range of characters to be used when generating. --- This consists of all lowercase Latin alphabet characters and the --- numbers 1 through 9. validChars :: [Char] -validChars = validLetters <> validNumbers +validChars = validLetters <> fmap intToDigit validNumbers -validNumbers :: [Char] -validNumbers = ['1'..'9'] +validNumbers :: [Int] +validNumbers = [1..9] validLetters :: [Char] validLetters = ['a'..'z'] + +validSymbols :: [Char] +validSymbols = ['!', '@', '#', '$', '%', '^', '&', '*'] diff --git a/src/Feature/Generation/Templates.hs b/src/Feature/Generation/Templates.hs index 5d23be9..41343e3 100644 --- a/src/Feature/Generation/Templates.hs +++ b/src/Feature/Generation/Templates.hs @@ -4,6 +4,7 @@ module Feature.Generation.Templates ( renderGen ) where import Core.Templates (hxVals) +import Feature.Generation.Passwords (Password) import qualified Data.Text as T import qualified Data.Text.Lazy as LT @@ -14,7 +15,5 @@ import Text.Hamlet (shamletFile) import Prelude -renderGen :: String -> LT.Text -renderGen genPw = renderHtml ( $(shamletFile "./views/gen.hamlet") ) - where - hsGeneratedSharing = hxVals "newSec" genPw +renderGen :: Password -> Password -> Password -> LT.Text +renderGen genXkcd genOldschool genGibberish = renderHtml ( $(shamletFile "./views/gen.hamlet") ) diff --git a/src/Feature/Generation/wordlist.txt b/src/Feature/Generation/wordlist.txt index 4c058c8..742d01f 100644 --- a/src/Feature/Generation/wordlist.txt +++ b/src/Feature/Generation/wordlist.txt @@ -654,7 +654,6 @@ humour hungry hunt hurry -hurt idea ideal ignore @@ -668,10 +667,7 @@ income indeed index indoor -infect inform -injure -injury inner insect insert @@ -862,14 +858,12 @@ move movie moving much -murder muscle museum music must myself nail -naked name narrow nation @@ -1242,7 +1236,6 @@ single sink site size -skill skin skirt sleep diff --git a/src/Feature/Sharing/HTTP.hs b/src/Feature/Sharing/HTTP.hs index 0a9b96d..7b38d18 100644 --- a/src/Feature/Sharing/HTTP.hs +++ b/src/Feature/Sharing/HTTP.hs @@ -1,5 +1,6 @@ module Feature.Sharing.HTTP ( routes ) where +import Core.SQLite (confLinkLength) import Core.Types import Core.Templates (renderIndex) @@ -21,7 +22,8 @@ routes = do get "/pw/:id" $ do reqId <- param "id" - html $ renderIndex reqId + conf <- lift ask + html $ renderIndex reqId (adminEmail conf) post "/pw" $ do reqId <- param "userLink" @@ -32,6 +34,7 @@ routes = do reqSecret <- param "newSec" reqDur <- param "newSecDuration" reqViews <- param "newSecViews" - link <- genLink - insertNewSecret reqSecret reqDur (T.pack link) reqViews - html $ renderPw link (Just reqSecret) + cLength <- confLinkLength + link <- liftIO $ genLink cLength + insertNewSecret reqSecret reqDur (T.pack $ show link) reqViews + html $ renderPw (show link) (Just reqSecret) diff --git a/src/Feature/Sharing/SQLite.hs b/src/Feature/Sharing/SQLite.hs index cdaae0d..7d080b5 100644 --- a/src/Feature/Sharing/SQLite.hs +++ b/src/Feature/Sharing/SQLite.hs @@ -2,6 +2,7 @@ module Feature.Sharing.SQLite where import Core.Types import Core.SQLite +import Feature.Generation.Passwords (Password) import Feature.Sharing.Types import Control.Monad.Reader (ask, lift, liftIO) diff --git a/views/cassius/style.cassius b/views/cassius/style.cassius index ae8870f..1b3cade 100644 --- a/views/cassius/style.cassius +++ b/views/cassius/style.cassius @@ -13,6 +13,9 @@ body font-size: 20px text-align: left +header + text-align: right + h2 font-family: monaco, Consolas, monospace text-transform: uppercase @@ -38,18 +41,6 @@ a .title h1 margin: 0.1em 0 0.1em 0 -.footer - position: absolute - text-align: right - bottom: 0 - width: 75% - height: 2.5em - -.footer a - all: unset - cursor: pointer - color: #{colorThree} - .htmx-indicator display: none @@ -57,6 +48,9 @@ a color: #{colorOne} opacity: 1 +.generators + margin: 0 0 0.5em 0 + .logo margin: 4% 3% 0 0 font-size: 1.2vw @@ -142,6 +136,9 @@ a color: #{colorThree} opacity: 0.5 +.genNew .numberInput + margin: 0 0 0.5em 0 + .genResult color: #{colorFour} @@ -178,6 +175,9 @@ a .genButton width: 80% + + .generators + text-align: left .mainInput width: 95% @@ -188,7 +188,7 @@ a width: 25% .title - margin: 8% auto 2% auto + margin: 4% auto 2% auto font-size: 3em .title h1 diff --git a/views/gen.hamlet b/views/gen.hamlet index 87a120d..ea1ea58 100644 --- a/views/gen.hamlet +++ b/views/gen.hamlet @@ -1,41 +1,50 @@

Generators -

#{genPw} -