Started building generation functionality, added useful haddock-style comments for several functions

Purr.cabal

@@ -25,6 +25,7 @@ library
       Core.Templates
       Core.Types
       Feature.Generation.Links
+      Feature.Generation.Passwords
       Feature.Generation.Shared
       Feature.Sharing.HTTP
       Feature.Sharing.SQLite

src/Core/HTTP.hs

@@ -18,7 +18,7 @@ app = do
 
   -- Core Routes
   get "/" $ do
-    html $ renderIndex "/" Nothing
+    html $ renderIndex "/"
 
   get "/style.css" $ do
     setHeader "Content-Type" "text/css"

src/Core/SQLite.hs

@@ -20,5 +20,5 @@ main db = do
 
 dbPath :: PurrAction String
 dbPath = do
-  conf <- lift ask
+  conf  <- lift ask
   return $ dbFile conf

src/Core/Templates.hs

@@ -13,8 +13,13 @@ import qualified Data.Text.Lazy as LT
 
 import Prelude 
 
-renderIndex :: String -> Maybe T.Text -> LT.Text
+renderIndex :: String -> LT.Text
-renderIndex link password = renderHtml ( $(shamletFile "./views/index.hamlet") )
+renderIndex link = renderHtml ( $(shamletFile "./views/index.hamlet") )
+  where
+    hsUserLink = userLinkAttr link
 
 renderStyle :: LT.Text
 renderStyle = renderCss ( $(cassiusFile "./views/cassius/style.cassius") "/style.css" )
+
+userLinkAttr :: String -> (String, String)
+userLinkAttr str = ("hx-vals", "{\"userLink\": \"" <> str <> "\"}")

src/Core/Types.hs

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

src/Feature/Generation/Links.hs

@@ -5,30 +5,45 @@ import Feature.Generation.Shared (rIndex)
 
 import Control.Monad.Reader (ask, lift, liftIO)
 import Data.Char (toLower, toUpper)
-import Data.List (foldl')
 import System.IO
 import System.Random
 
-genLink :: Int -> [Char] -> IO [Char]
+-- Generates a string containing randomly generated and capitalized
-genLink 0 cs = return cs
+-- characters. The number of characters used is defined in the global config.dhall.
-genLink d cs = do 
+genLink :: PurrAction String
-  res <- rChar
+genLink = do 
-  fin <- rCap res
+  linkLength <- confLinkLength
-  genLink (d - 1) (cs <> (fin:[]))
+  genLink' linkLength ""
+  where
+    genLink' 0 cs = return cs
+    genLink' d cs = do
+      res <- liftIO $ randChar
+      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']
 
-rChar :: IO Char
+randChar :: IO Char
-rChar = rIndex validChars
+randChar = rIndex validChars
 
-rCap :: Char -> IO Char -- rCap takes a single character and returns it
+randCapitalization :: Char -> IO Char
-rCap c = do             -- capitalized or lowercased at random.
+randCapitalization c = do 
   capRand <- randomRIO (0,1)
-  return $ checkRand capRand c
+  return $ go capRand c
     where
-      checkRand :: Int -> Char -> Char
+      go :: Int -> Char -> Char
-      checkRand r c 
+      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

@@ -0,0 +1,25 @@
+module Feature.Generation.Passwords where
+
+import Core.Types
+import Feature.Generation.Shared (rIndex)
+
+import Control.Monad.Reader (ask, lift, liftIO)
+import Data.Char (toLower, toUpper)
+import System.IO
+import System.Random
+
+-- suggestedScheme and its helpers xkcd, oldschool, and gibberish are TODO.
+suggestedScheme :: Int -> String
+suggestedScheme i 
+  | i > 23    = xkcd i
+  | i > 12    = oldschool i
+  | otherwise = gibberish i
+
+xkcd :: Int -> String
+xkcd i = take i "correcthorsebatterystaple"
+
+oldschool :: Int -> String
+oldschool i = take i "PowerProlonger2974!"
+
+gibberish :: Int -> String
+gibberish i = take i "TCYx#@z5zlgw1o"

src/Feature/Sharing/HTTP.hs

@@ -21,8 +21,7 @@ routes = do
 
   get "/pw/:id" $ do
     reqId <- param "id"
-    res   <- findByLink reqId
+    html   $ renderIndex reqId
-    html   $ renderIndex reqId (secret <$> res)
 
   post "/pw" $ do
     reqId <- param "userLink"
@@ -31,6 +30,6 @@ routes = do
 
   post "/new" $ do 
     reqSecret <- param "newSec"
-    link      <- liftIO $ genLink 24 ""
+    link      <- genLink
     insertNewSecret reqSecret (T.pack link)
     html       $ renderPw link (Just reqSecret)

views/index.hamlet

@@ -1,5 +1,6 @@
 $doctype 5
 <html>
+
   <head>
     <title>Purr
     <meta name="viewport" content="width=device-width, initial-scale=1.0">
@@ -7,24 +8,28 @@ $doctype 5
     <link rel="stylesheet" href="/style.css">
 
   <body>
+
     <div #logo .logo>
       <img src="/purrlogo.png">
+
     <div #content .content>
       <div #title .title>
         <h1>
           <a #titleLink .titleLink href="/">Purr
+
       <div #pwUtils .pwUtils>
-        $# Below needs to be replaced with an HTMX onload request to /pw/#{link} to DRY
+        $if (link == "/")
-        <div #requestedPw .requestedPw>
+          <div #requestedPw .requestedPw>
-          $maybe pw <- password
+            <p .emptyReq>
-            <p>Here's the secret for <a href="/pw/#{link}">/pw/#{link}</a>:
+        $else
-            <h2 .pwResult>#{pw}
+          <div #requestedPw .requestedPw
-          $nothing
+            hx-trigger="load"
-            $if (link == "/")
+            hx-post="/pw"
-              <p .emptyReq>
+            hx-target="#requestedPw"
-            $else
+            hx-swap="outerHTML"
-              <p>No secret available at <a href="/pw/#{link}">/pw/#{link}</a>
+            *{hsUserLink}
-        $# Above needs to be replaced with an HTMX onload request to /pw/#{link} to DRY
+          >
+           Loading... <img class="htmx-indicator" src="/loading.svg" />
 
         <div #shareNew .shareNew>
           <p>

views/pw.hamlet

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