From bbe315c450731a1b0b1225e02fa4b6d3d126f94c Mon Sep 17 00:00:00 2001 From: James Eversole Date: Fri, 29 Jul 2022 17:40:45 -0500 Subject: [PATCH] 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 | 2 + examples/config.dhall | 2 + src/Core/HTTP.hs | 6 ++- src/Core/Templates.hs | 8 ++-- src/Core/Types.hs | 1 + src/Feature/Generation/HTTP.hs | 22 +++++++++++ src/Feature/Generation/Links.hs | 8 +--- src/Feature/Generation/Passwords.hs | 38 +++++++++++++++---- src/Feature/Generation/Shared.hs | 12 ++++++ src/Feature/Generation/Templates.hs | 20 ++++++++++ .../Generation/wordlist.txt} | 4 +- views/cassius/style.cassius | 14 +++++-- views/gen.hamlet | 19 ++++++++++ views/index.hamlet | 10 +++++ views/pw.hamlet | 5 ++- 15 files changed, 142 insertions(+), 29 deletions(-) create mode 100644 src/Feature/Generation/HTTP.hs create mode 100644 src/Feature/Generation/Templates.hs rename src/{wordlist => Feature/Generation/wordlist.txt} (99%) create mode 100644 views/gen.hamlet diff --git a/Purr.cabal b/Purr.cabal index 1b6492e..528c24a 100644 --- a/Purr.cabal +++ b/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 diff --git a/examples/config.dhall b/examples/config.dhall index 1cc4259..385c1e6 100644 --- a/examples/config.dhall +++ b/examples/config.dhall @@ -10,4 +10,6 @@ , applicationHost = "REPLACEME" , applicationPort = +3000 , dbFile = "data/Purr.sqlite" +, dbSalt = "REPLACEME!!!!!" +, linkLength = +24 } diff --git a/src/Core/HTTP.hs b/src/Core/HTTP.hs index a231fcf..a7eba7d 100644 --- a/src/Core/HTTP.hs +++ b/src/Core/HTTP.hs @@ -2,8 +2,9 @@ module Core.HTTP ( app ) where import Core.Types -import Core.Templates (renderIndex, renderStyle) -import Feature.Sharing.HTTP as Sharing +import Core.Templates (renderIndex, renderStyle) +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 diff --git a/src/Core/Templates.hs b/src/Core/Templates.hs index 092c829..859d7f9 100644 --- a/src/Core/Templates.hs +++ b/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) -userLinkAttr str = ("hx-vals", "{\"userLink\": \"" <> str <> "\"}") +hxVals :: String -> String -> (String, String) +hxVals attr str = ("hx-vals", "{\"" <> attr <> "\": \"" <> str <> "\"}") diff --git a/src/Core/Types.hs b/src/Core/Types.hs index 394d904..de6b03e 100644 --- a/src/Core/Types.hs +++ b/src/Core/Types.hs @@ -20,5 +20,6 @@ data DhallConfig = DhallConfig , applicationHost :: String , applicationPort :: Int , dbFile :: String + , dbSalt :: String , linkLength :: Int } deriving (Generic, Show) diff --git a/src/Feature/Generation/HTTP.hs b/src/Feature/Generation/HTTP.hs new file mode 100644 index 0000000..74ddd0d --- /dev/null +++ b/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 diff --git a/src/Feature/Generation/Links.hs b/src/Feature/Generation/Links.hs index dd4981d..359bfa4 100644 --- a/src/Feature/Generation/Links.hs +++ b/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 diff --git a/src/Feature/Generation/Passwords.hs b/src/Feature/Generation/Passwords.hs index fc726f4..d160682 100644 --- a/src/Feature/Generation/Passwords.hs +++ b/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 i = take i "correcthorsebatterystaple" +xkcd :: Int -> IO String +xkcd i = do + wOne <- randomCamel + wTwo <- randomCamel + wThree <- randomCamel + wFour <- randomCamel + return $ wOne <> wTwo <> wThree <> wFour -oldschool :: Int -> String -oldschool i = take i "PowerProlonger2974!" +oldschool :: Int -> IO String +oldschool i = do + wOne <- randomWord + wTwo <- randomWord + return $ wOne <> wTwo -gibberish :: Int -> String -gibberish i = take i "TCYx#@z5zlgw1o" +gibberish :: Int -> IO String +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 diff --git a/src/Feature/Generation/Shared.hs b/src/Feature/Generation/Shared.hs index c46b3e3..cb9cc9f 100644 --- a/src/Feature/Generation/Shared.hs +++ b/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'] diff --git a/src/Feature/Generation/Templates.hs b/src/Feature/Generation/Templates.hs new file mode 100644 index 0000000..5d23be9 --- /dev/null +++ b/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 diff --git a/src/wordlist b/src/Feature/Generation/wordlist.txt similarity index 99% rename from src/wordlist rename to src/Feature/Generation/wordlist.txt index 3beab81..b1dafc2 100644 --- a/src/wordlist +++ b/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 diff --git a/views/cassius/style.cassius b/views/cassius/style.cassius index e073cdb..f0d894c 100644 --- a/views/cassius/style.cassius +++ b/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 - border-style: none none none none + margin: 0.5em 0 + 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 diff --git a/views/gen.hamlet b/views/gen.hamlet new file mode 100644 index 0000000..ad06b58 --- /dev/null +++ b/views/gen.hamlet @@ -0,0 +1,19 @@ +
+

Generators +

Generated password: +

#{genPw} +