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

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 link password = renderHtml ( $(shamletFile "./views/index.hamlet") )
+renderIndex :: String -> LT.Text
+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]
-genLink 0 cs = return cs
-genLink d cs = do 
-  res <- rChar
-  fin <- rCap res
-  genLink (d - 1) (cs <> (fin:[]))
+-- 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:[]))
 
+-- 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
-rChar = rIndex validChars
+randChar :: IO Char
+randChar = rIndex validChars
 
-rCap :: Char -> IO Char -- rCap takes a single character and returns it
-rCap c = do             -- capitalized or lowercased at random.
+randCapitalization :: Char -> IO Char
+randCapitalization c = do 
   capRand <- randomRIO (0,1)
-  return $ checkRand capRand c
+  return $ go capRand c
     where
-      checkRand :: Int -> Char -> Char
-      checkRand r c 
+      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

@@ -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 (secret <$> res)
+    html   $ renderIndex reqId
 
   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)