Random generation of xkcd-style passwords now functioning as expected, web interface now serves randomly generated xkcd-style passwords and provides a button to create a sharing link for them when a new generation is requested. Misc stylesheet updates. Generalized the hx-vals helper function in Core.Templates to be useful for arbitrary endpoints that will need to include specific JSON. Added configuration field for dbSalt which will be used as an encryption salt in the next commit when passwods are stored encrypted in the DB instead of in plaintext.

Purr.cabal

@@ -24,9 +24,11 @@ library
       Core.SQLite
       Core.Templates
       Core.Types
+      Feature.Generation.HTTP
       Feature.Generation.Links
       Feature.Generation.Passwords
       Feature.Generation.Shared
+      Feature.Generation.Templates
       Feature.Sharing.HTTP
       Feature.Sharing.SQLite
       Feature.Sharing.Templates

examples/config.dhall

@@ -10,4 +10,6 @@
 , applicationHost = "REPLACEME"
 , applicationPort = +3000
 , dbFile          = "data/Purr.sqlite"
+, dbSalt          = "REPLACEME!!!!!"
+, linkLength      = +24
 }

src/Core/HTTP.hs

@@ -2,8 +2,9 @@ module Core.HTTP ( app ) where
 
 import Core.Types
 
-import Core.Templates       (renderIndex, renderStyle)
+import Core.Templates          (renderIndex, renderStyle)
-import Feature.Sharing.HTTP as Sharing
+import Feature.Sharing.HTTP    as Sharing
+import Feature.Generation.HTTP as Generation
 
 import Data.Maybe                           (Maybe (Nothing))
 import Network.Wai.Middleware.RequestLogger (logStdoutDev)
@@ -26,3 +27,4 @@ app = do
 
   -- Feature Routes
   Sharing.routes
+  Generation.routes

src/Core/Templates.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE TemplateHaskell #-}
 
-module Core.Templates ( renderIndex, renderStyle ) where
+module Core.Templates ( renderIndex, renderStyle, hxVals ) where
 
 import Text.Blaze.Html.Renderer.Text (renderHtml)
 import Text.Blaze.Html
@@ -16,10 +16,10 @@ import Prelude
 renderIndex :: String -> LT.Text
 renderIndex link = renderHtml ( $(shamletFile "./views/index.hamlet") )
   where
-    hsUserLink = userLinkAttr link
+    hsUserLink = hxVals "userLink" link
 
 renderStyle :: LT.Text
 renderStyle = renderCss ( $(cassiusFile "./views/cassius/style.cassius") "/style.css" )
 
-userLinkAttr :: String -> (String, String)
+hxVals :: String -> String -> (String, String)
-userLinkAttr str = ("hx-vals", "{\"userLink\": \"" <> str <> "\"}")
+hxVals attr str = ("hx-vals", "{\"" <> attr <> "\": \"" <> str <> "\"}")

src/Core/Types.hs

@@ -20,5 +20,6 @@ data DhallConfig = DhallConfig
   , applicationHost :: String
   , applicationPort :: Int
   , dbFile          :: String
+  , dbSalt          :: String
   , linkLength      :: Int
   } deriving (Generic, Show)

src/Feature/Generation/HTTP.hs

@@ -0,0 +1,22 @@
+module Feature.Generation.HTTP ( routes ) where
+
+import Core.Types
+import Core.Templates (renderIndex)
+
+import Feature.Generation.Passwords (suggestedScheme)
+import Feature.Generation.Templates (renderGen)
+
+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 
+
+routes :: PurrApp ()
+routes = do 
+
+  get "/gen" $ do
+    genPw <- liftIO $ suggestedScheme 24
+    html   $ renderGen genPw

src/Feature/Generation/Links.hs

@@ -1,7 +1,7 @@
 module Feature.Generation.Links ( genLink ) where
 
 import Core.Types
-import Feature.Generation.Shared (rIndex)
+import Feature.Generation.Shared (rIndex, validChars)
 
 import Control.Monad.Reader (ask, lift, liftIO)
 import Data.Char (toLower, toUpper)
@@ -21,12 +21,6 @@ genLink = do
       fin <- liftIO $ randCapitalization res
       genLink' (d - 1) (cs <> (fin:[]))
 
--- Defines the valid range of characters to be used when generating links.
--- This consists of all lowercase Latin alphabet characters and the 
--- numbers 1 through 9.
-validChars :: [Char]
-validChars = ['a'..'z'] <> ['1'..'9']
-
 randChar :: IO Char
 randChar = rIndex validChars
 

src/Feature/Generation/Passwords.hs

@@ -1,25 +1,47 @@
 module Feature.Generation.Passwords where
 
 import Core.Types
-import Feature.Generation.Shared (rIndex)
+import Feature.Generation.Shared (rIndex, validChars)
 
 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)
+
 -- suggestedScheme and its helpers xkcd, oldschool, and gibberish are TODO.
-suggestedScheme :: Int -> String
+suggestedScheme :: Int -> IO String
 suggestedScheme i 
   | i > 23    = xkcd i
   | i > 12    = oldschool i
   | otherwise = gibberish i
 
-xkcd :: Int -> String
+xkcd :: Int -> IO String
-xkcd i = take i "correcthorsebatterystaple"
+xkcd i = do
+  wOne   <- randomCamel
+  wTwo   <- randomCamel
+  wThree <- randomCamel
+  wFour  <- randomCamel
+  return  $ wOne <> wTwo <> wThree <> wFour
 
-oldschool :: Int -> String
+oldschool :: Int -> IO String
-oldschool i = take i "PowerProlonger2974!"
+oldschool i = do
+  wOne  <- randomWord
+  wTwo  <- randomWord
+  return $ wOne <> wTwo
 
-gibberish :: Int -> String
+gibberish :: Int -> IO String
-gibberish i = take i "TCYx#@z5zlgw1o"
+gibberish i = return "mf98sgs7bgg%#"
+
+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

@@ -6,3 +6,15 @@ rIndex :: [a] -> IO a
 rIndex arr = do
   i <- randomRIO (0, length arr - 1)
   return $ arr !! i
+
+-- 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
+
+validNumbers :: [Char]
+validNumbers = ['1'..'9']
+
+validLetters :: [Char]
+validLetters = ['a'..'z']

src/Feature/Generation/Templates.hs

@@ -0,0 +1,20 @@
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Feature.Generation.Templates ( renderGen ) where
+
+import Core.Templates (hxVals)
+
+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 Prelude 
+
+renderGen :: String -> LT.Text
+renderGen genPw = renderHtml ( $(shamletFile "./views/gen.hamlet") )
+  where
+   hsGeneratedSharing = hxVals "newSec" genPw

src/Feature/Generation/wordlist.txt

@@ -195,6 +195,7 @@ bury
 bush
 busy
 butter
+butterfly
 button
 buyer
 cable
@@ -605,7 +606,6 @@ hall
 hammer
 hand
 handle
-hang
 happen
 happy
 hard
@@ -614,7 +614,6 @@ harm
 hate
 hatred
 have
-head
 heal
 health
 hear
@@ -628,7 +627,6 @@ help
 hence
 here
 hero
-hers
 hide
 high
 highly

views/cassius/style.cassius

@@ -4,14 +4,18 @@
 @colorFour:  #435F5D
 
 html
+  font-family: 			Courier
   background-color: #{colorTwo}
   color: 						#{colorOne}
 
 body
-  font-family: 			Courier
   font-size:        20px
   text-align: 			left
 
+h2
+  font-family:    monaco, Consolas, monospace
+  text-transform: uppercase
+
 p
   margin: 0.4em 0 0.4em 0
 
@@ -38,6 +42,7 @@ a
   height: 1%
 
 .mainButton
+  margin:           0 0 0.25em 0
   padding: 					0.75em 1.75em
   background-color: #{colorThree}
   color: 					  #{colorTwo}
@@ -51,8 +56,8 @@ a
   outline: 						none
   color: 							#{colorOne}
   background: 				#{colorTwo}
-  margin: 						1em 0
+  margin: 						0.5em 0
-  border-style:				none none none none
+  border-style:				none none solid none
   padding: 						0.4em 0
   box-sizing: 				border-box
   -webkit-box-sizing: border-box
@@ -77,6 +82,9 @@ a
 .pwUtils
   width:  75%
 
+.generators
+  margin: 5% 0 0 0
+
 .shareNew
   margin-bottom: 2em
 

views/gen.hamlet

@@ -0,0 +1,19 @@
+<div #generators .generators>
+  <h2>Generators
+  <p>Generated password: 
+  <h3>#{genPw} 
+  <button .mainButton
+    hx-get="/gen"
+    hx-target="#generators"
+    hx-swap="outerHTML"
+  />
+    Generate New Password
+  <br />
+  <button .mainButton
+    hx-post="/new"
+    hx-target="#requestedPw"
+    hx-swap="outerHTML"
+    *{hsGeneratedSharing}
+  />
+    Share Generated Password
+    <img class="htmx-indicator" src="/loading.svg" />

views/index.hamlet

@@ -18,6 +18,7 @@ $doctype 5
           <a #titleLink .titleLink href="/">Purr
 
       <div #pwUtils .pwUtils>
+        <h2>Sharing Tools
         $if (link == "/")
           <div #requestedPw .requestedPw>
             <p .emptyReq>
@@ -62,3 +63,12 @@ $doctype 5
           />
             Get Secret
             <img class="htmx-indicator" src="/loading.svg" />
+
+        <div #generators .generators>
+          <h2>Generators
+          <button .mainButton
+            hx-get="/gen"
+            hx-target="#generators"
+            hx-swap="outerHTML"
+          />
+            Generate Password

views/pw.hamlet

@@ -1,6 +1,7 @@
 <div #requestedPw .requestedPw>
   $maybe pw <- password
     <p>Here's the secret found at <a href="/pw/#{link}">/pw/#{link}</a>:
-    <h2 .pwResult>#{pw}
+    <h3 .pwResult>#{pw}
+    <hr />
   $nothing
-    <p>No secret found at <a href="/pw/#{link}">/pw/#{link}</a>
+    <h3>No secret found at <a href="/pw/#{link}">/pw/#{link}</a>