commit 2a4787fc8435fcaaff7101610c5e3c7f4ca12982
parent 3c4c4f8d305fff7313efb56360864cf72257a298
Author: James Eversole <james@eversole.co>
Date: Sun, 7 Aug 2022 16:22:09 -0500
Refactor excessive do notation. Complete oldschool and gibberish generators. Add frontend functionality for selecting from multiple generator styles. Add config requirement for admin email. Add admin email to header.
Diffstat:
16 files changed, 197 insertions(+), 159 deletions(-)
diff --git 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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
--- characters. The number of characters used is defined in the global config.dhall.
-genLink :: PurrAction String
-genLink = do
- linkLength <- confLinkLength
- genLink' linkLength ""
- 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
+newtype GenLink = GenLink' String
+ deriving (Eq, Ord)
-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
+instance Show GenLink where
+ show (GenLink' a) = a
--- 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
+-- Generates a string containing romly generated and capitalized
+-- characters. The number of characters used is defined in the global config.dhall.
+genLink :: Int -> IO GenLink
+genLink linkLength = genLink' linkLength (return "")
+ where
+ 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
@@ -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))
-wordList :: IO [String]
-wordList = fmap lines (readFile "./src/Feature/Generation/wordlist.txt")
+rNum :: IO Int
+rNum = rIndex validNumbers
+
+rWord :: IO String
+rWord = wordList >>= rIndex
-randomWord :: IO String
-randomWord = wordList >>= rIndex
+rSym :: IO Char
+rSym = rIndex validSymbols
-randomCamel :: IO String
-randomCamel = camelCase <$> randomWord
+rCamel :: IO String
+rCamel = camelCase <$> rWord
+
+wordList :: IO [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,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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -1,41 +1,50 @@
<div #generators .column>
<h2>Generators
- <h3 .genResult>#{genPw}
- <button .genButton
- hx-get="/gen"
- hx-target="#generators"
- hx-swap="outerHTML"
- />
- Generate New
- <br />
-
- <button .genButton
- hx-post="/new"
- hx-target="#requestedPw"
- hx-swap="outerHTML"
- hx-include="[id='generators']"
- *{hsGeneratedSharing}
- />
- Share Password
- <img class="htmx-indicator" src="/loading.svg" />
-
- <div .validForm>
- Valid for:
+ <h3>Random, Classic, XKCD
+ <form id="genForm">
+ <div .generators">
+ <input type="radio" id="gibberish" name="newSec" value="#{show genGibberish}">
+ <label for="gibberish" .genResult>#{show genGibberish}
+ <br />
+ <input type="radio" id="oldschool" name="newSec" value="#{show genOldschool}">
+ <label for="oldschool" .genResult>#{show genOldschool}
+ <br />
+ <input type="radio" id="xkcd" name="newSec" value="#{show genXkcd}">
+ <label for="xkcd" .genResult>#{show genXkcd}
+ <button .genButton
+ hx-get="/gen"
+ hx-target="#generators"
+ hx-swap="outerHTML"
+ />
+ Generate New
<br />
- <input .numberInput
- name="newSecDuration"
- type="number"
- min="1"
- max="90"
- value="20"
- onkeyup="if (value < 1 || value > 90) { value = 0 }"
- /> days
- <input .numberInput
- name="newSecViews"
- type="number"
- min="1"
- max="60"
- value="20"
- onkeyup="if (value < 1 || value > 60) { value = 0 }"
- /> views
+
+ <div .validForm>
+ <h3>Share Generated Password
+ Valid for:
+ <br />
+ <input .numberInput
+ name="newSecDuration"
+ type="number"
+ min="1"
+ max="90"
+ value="20"
+ onkeyup="if (value < 1 || value > 90) { value = 0 }"
+ /> days
+ <input .numberInput
+ name="newSecViews"
+ type="number"
+ min="1"
+ max="60"
+ value="20"
+ onkeyup="if (value < 1 || value > 60) { value = 0 }"
+ /> views
+ <button .genButton
+ hx-post="/new"
+ hx-target="#requestedPw"
+ hx-swap="outerHTML"
+ hx-include="[name='newSec']"
+ />
+ Share Password
+ <img class="htmx-indicator" src="/loading.svg" />
diff --git a/views/index.hamlet b/views/index.hamlet
@@ -9,6 +9,11 @@ $doctype 5
<body>
+ <header>
+ <a href="https://git.eversole.co/James/Purr">
+ Made with ♥
+ | <a href="mailto:#{email}">Contact
+
<div #title .title>
<h1>
<a #titleLink .titleLink href="/">Purr
@@ -91,7 +96,3 @@ $doctype 5
hx-swap="outerHTML"
/>
Load Generators
-
- <footer .footer #footer>
- <a href="https://git.eversole.co/James/Purr">
- Made With ♥
