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.

examples/config.dhall

@@ -12,4 +12,5 @@
 , dbFile          = "data/Purr.sqlite"
 , dbKey           = "REPLACEME!!!!!"
 , linkLength      = +24
+, adminEmail      = "james@eversole.co"
 }

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"

src/Core/SQLite.hs

@@ -22,11 +22,10 @@ main db = do
   close conn
 
 dbPath :: PurrAction String
-dbPath = do
+dbPath = lift ask >>= (\a -> return $ dbFile a)
-  conf  <- lift ask
-  return $ dbFile conf
 
 encKey :: PurrAction String
-encKey = do
+encKey = lift ask >>= (\a -> return $ dbKey a)
-  conf  <- lift ask
+
-  return $ dbKey conf
+confLinkLength :: PurrAction Int
+confLinkLength = lift ask >>= (\a -> return $ linkLength a)

src/Core/Templates.hs

@@ -13,8 +13,8 @@ import qualified Data.Text.Lazy as LT
 
 import Prelude 
 
-renderIndex :: String -> LT.Text
+renderIndex :: String -> String -> LT.Text
-renderIndex link = renderHtml ( $(shamletFile "./views/index.hamlet") )
+renderIndex link email = renderHtml ( $(shamletFile "./views/index.hamlet") )
   where
     hsUserLink = hxVals "userLink" link
 

src/Core/Types.hs

@@ -22,4 +22,5 @@ data DhallConfig = DhallConfig
   , dbFile          :: String
   , dbKey           :: String
   , linkLength      :: Int
+  , adminEmail      :: String
   } deriving (Generic, Show)

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
+    genXkcd      <- liftIO $ xkcd
-    html   $ renderGen genPw
+    genOldschool <- liftIO $ oldschool
+    genGibberish <- liftIO $ gibberish 12
+    html   $ renderGen genXkcd genOldschool genGibberish

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 Control.Monad.Reader (ask, lift)
-import Data.Char (toLower, toUpper)
+import Data.List (singleton)
-import System.IO
-import System.Random
 
--- 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 :: Int -> IO GenLink
-genLink = do 
+genLink linkLength = genLink' linkLength (return "")
-  linkLength <- confLinkLength
-  genLink' linkLength ""
   where
-    genLink' 0 cs = return cs
+    genLink' 0 cs = GenLink' <$> cs
-    genLink' d cs = do
+    genLink' d cs = genLink' (d - 1) (cs <> (singleton <$> rChar))
-      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

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]
+newtype Password = Password' String
-camelCase [] = []
+  deriving (Eq, Ord)
-camelCase x = toUpper (head x) : map toLower (tail x)
 
--- suggestedScheme and its helpers xkcd, oldschool, and gibberish are TODO.
+instance Show Password where 
-suggestedScheme :: Int -> IO String
+  show (Password' a) = a
+
+suggestedScheme :: Int -> IO Password
 suggestedScheme i 
-  | i > 23    = xkcd i
+  | i > 17    = xkcd
-  | i > 12    = oldschool i
+  | i > 12    = oldschool
   | otherwise = gibberish i
 
-xkcd :: Int -> IO String
+xkcd :: IO Password
-xkcd i = do
+xkcd = do
-  wOne   <- randomCamel
+  wOne   <- rCamel
-  wTwo   <- randomCamel
+  wTwo   <- rCamel
-  wThree <- randomCamel
+  wThree <- rCamel
-  wFour  <- randomCamel
+  wFour  <- rCamel
-  return  $ wOne <> wTwo <> wThree <> wFour
+  return  $ Password' (wOne <> wTwo <> wThree <> wFour)
 
-oldschool :: Int -> IO String
+oldschool :: IO Password
-oldschool i = do
+oldschool = do
-  wOne  <- randomWord
+  wOne <- rCamel
-  wTwo  <- randomWord
+  wTwo <- rCamel
-  return $ wOne <> wTwo
+  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 :: Int -> IO Password
-gibberish i = return "mf98sgs7bgg%#"
+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

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
+rIndex arr = randomRIO (0, length arr - 1) 
-  i <- randomRIO (0, length arr - 1)
+  >>= (\i -> return $ arr !! 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 :: [Int]
-validNumbers = ['1'..'9']
+validNumbers = [1..9]
 
 validLetters :: [Char]
 validLetters = ['a'..'z']
+
+validSymbols :: [Char]
+validSymbols = ['!', '@', '#', '$', '%', '^', '&', '*']

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 :: Password -> Password -> Password -> LT.Text
-renderGen genPw = renderHtml ( $(shamletFile "./views/gen.hamlet") )
+renderGen genXkcd genOldschool genGibberish = renderHtml ( $(shamletFile "./views/gen.hamlet") )
-  where
-   hsGeneratedSharing = hxVals "newSec" genPw

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

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
+    cLength   <- confLinkLength
-    insertNewSecret reqSecret reqDur (T.pack link) reqViews
+    link      <- liftIO $ genLink cLength
-    html       $ renderPw link (Just reqSecret)
+    insertNewSecret reqSecret reqDur (T.pack $ show link) reqViews
+    html       $ renderPw (show link) (Just reqSecret)

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)

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

views/gen.hamlet

@@ -1,41 +1,50 @@
 <div #generators .column>
   <h2>Generators
-  <h3 .genResult>#{genPw} 
+  <h3>Random, Classic, XKCD
-  <button .genButton
+  <form id="genForm">
-    hx-get="/gen"
+    <div .generators">
-    hx-target="#generators"
+      <input type="radio" id="gibberish" name="newSec" value="#{show genGibberish}">
-    hx-swap="outerHTML"
+      <label for="gibberish" .genResult>#{show genGibberish}
-  />
+      <br />
-    Generate New
+      <input type="radio" id="oldschool" name="newSec" value="#{show genOldschool}">
-  <br />
+      <label for="oldschool" .genResult>#{show genOldschool}
-
+      <br />
-  <button .genButton
+      <input type="radio" id="xkcd" name="newSec" value="#{show genXkcd}">
-    hx-post="/new"
+      <label for="xkcd" .genResult>#{show genXkcd}
-    hx-target="#requestedPw"
+    <button .genButton
-    hx-swap="outerHTML"
+      hx-get="/gen"
-    hx-include="[id='generators']"
+      hx-target="#generators"
-    *{hsGeneratedSharing}
+      hx-swap="outerHTML"
-  />
+    />
-    Share Password
+      Generate New
-    <img class="htmx-indicator" src="/loading.svg" />
-
-  <div .validForm>
-    Valid for:
     <br />
-    <input .numberInput
+
-      name="newSecDuration"
+    <div .validForm>
-      type="number"
+      <h3>Share Generated Password
-      min="1"
+      Valid for:
-      max="90"
+      <br />
-      value="20"
+      <input .numberInput
-      onkeyup="if (value < 1 || value > 90) { value = 0 }"
+        name="newSecDuration"
-    /> days
+        type="number"
-    <input .numberInput
+        min="1"
-      name="newSecViews"
+        max="90"
-      type="number"
+        value="20"
-      min="1"
+        onkeyup="if (value < 1 || value > 90) { value = 0 }"
-      max="60"
+      /> days
-      value="20"
+      <input .numberInput
-      onkeyup="if (value < 1 || value > 60) { value = 0 }"
+        name="newSecViews"
-    /> views
+        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" />
 

views/index.hamlet

@@ -9,6 +9,11 @@ $doctype 5
 
   <body>
 
+    <header>
+      <a href="https://git.eversole.co/James/Purr">
+        Made with &#9829;
+      | <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 &#9829;