commit 4909bb9c962e965dd746e554c23a2cdc38769770
parent 7796fcb9b4b229ffa54cae2101aec6e528f4bce4
Author: James Eversole <james@eversole.co>
Date: Sat, 17 Feb 2024 14:56:13 -0600
Extensive commenting of functions; refactor some duplicate pattern matching logic
Diffstat:
11 files changed, 105 insertions(+), 62 deletions(-)
diff --git a/src/Core/Configuration.hs b/src/Core/Configuration.hs
@@ -9,6 +9,7 @@ import Configuration.Dotenv
import System.Directory (doesFileExist)
import System.Environment (getEnv, lookupEnv)
+-- Make the dotenv file configuration available if PURRNOFILE is not present
main :: IO ()
main = do
envFile <- lookupEnv "PURRNOFILE"
@@ -16,6 +17,7 @@ main = do
Nothing -> loadFile defaultConfig
_ -> putStrLn "Not using dotenv file"
+-- Check if an encryption key exists on the filesystem and create one if not
keyFileInit :: IO ()
keyFileInit = do
dataPathStr <- dataPath
@@ -27,6 +29,13 @@ keyFileInit = do
B.writeFile (dataPathStr ++ "data/encryptionKey") (encode key)
putStrLn "Creating new encryption key; any pre-existing DB entries will not decrypt"
+-- Read and return the encryption key on the filesystem as a ByteString
+encKey :: IO B.ByteString
+encKey = do
+ dataPathStr <- dataPath
+ B.readFile (dataPathStr ++ "data/encryptionKey")
+
+-- Helper functions for getting the value of environment variables
adminEmail :: IO String
adminEmail = getEnv "ADMINEMAIL"
@@ -41,8 +50,3 @@ dbPath = "data/Purr.sqlite"
confLinkLength :: IO String
confLinkLength = getEnv "LINKLENGTH"
-
-encKey :: IO B.ByteString
-encKey = do
- dataPathStr <- dataPath
- B.readFile (dataPathStr ++ "data/encryptionKey")
diff --git a/src/Core/HTTP.hs b/src/Core/HTTP.hs
@@ -15,7 +15,7 @@ import Web.Scotty
app :: PurrApp ()
app = do
- -- Middleware definition
+ -- Middleware that are processed on every request
middleware logStdoutDev
middleware $ staticPolicy (noDots >-> addBase "data/assets/public")
diff --git a/src/Core/SQLite.hs b/src/Core/SQLite.hs
@@ -9,6 +9,7 @@ import Database.SQLite.Simple.FromRow
import qualified Data.Text as T
+-- Set up SQLite database table when Purr starts if it doesn't already exist
main :: IO ()
main = do
conn <- open dbPath
diff --git a/src/Core/Types.hs b/src/Core/Types.hs
@@ -11,6 +11,7 @@ import Numeric.Natural (Natural)
import Text.Blaze.Html
import Web.Scotty (ActionM, ScottyM)
+-- Vestigial types from when Purr used a ReaderT in the monad stack
type PurrApp a = ScottyM a
type PurrAction a = ActionM a
type Random a = IO a
@@ -24,6 +25,7 @@ newtype UserSecret = UserSecret' String
newtype GenLink = GenLink' String
deriving (Eq, Ord)
+-- This record type matches Purr's SQL table columns
data SecretEntry = SecretEntry
{ link :: T.Text
, secret :: T.Text
diff --git a/src/Feature/Generation/HTTP.hs b/src/Feature/Generation/HTTP.hs
@@ -14,6 +14,9 @@ import Data.Maybe (listToMaybe)
import Prelude
import Web.Scotty
+{- "Generator" route that provides radio button options to share a randomly
+ generated password. This usecase targets IT professionals that are setting
+ up temporary account credentials for someone else. -}
routes :: PurrApp ()
routes = do
get "/gen" $ do
diff --git a/src/Feature/Generation/Links.hs b/src/Feature/Generation/Links.hs
@@ -4,8 +4,8 @@ import Core.Types
import Data.List (singleton)
import Feature.Generation.Shared (rChar, rIndex, validChars)
--- Generates a string containing romly generated and capitalized
--- characters. The number of characters used is defined in the global config.dhall.
+{- Generates a string containing randomly generated and capitalized characters.
+ The length is determined by the LINKLENGTH environment variable. -}
genLink :: Int -> IO GenLink
genLink linkLength = genLink' linkLength (return "")
where
diff --git a/src/Feature/Generation/Passwords.hs b/src/Feature/Generation/Passwords.hs
@@ -10,31 +10,35 @@ module Feature.Generation.Passwords
) where
import Core.Types
-import Feature.Generation.Shared (camelCase, rCharSym, rIndex,
+import Feature.Generation.Shared (titleCase, rCharSym, rIndex,
validChars, validNumbers,
validSymbols)
import Data.FileEmbed
import Data.List (singleton)
+{- Suggests one of Purr's generation schemes based on the
+ desired number of characters in the password. -}
suggestedScheme :: Int -> Random Password
suggestedScheme i
| i > 17 = xkcd
| i > 12 = oldschool
| otherwise = gibberish i
+-- XKCD-style random password generator consisting of four titlecase words.
xkcd :: Random Password
xkcd = do
- wOne <- rCamel
- wTwo <- rCamel
- wThree <- rCamel
- wFour <- rCamel
+ wOne <- rTitle
+ wTwo <- rTitle
+ wThree <- rTitle
+ wFour <- rTitle
return $ Password' (wOne <> wTwo <> wThree <> wFour)
+-- Two random title case words, four random numbers, one random symbol.
oldschool :: Random Password
oldschool = do
- wOne <- rCamel
- wTwo <- rCamel
+ wOne <- rTitle
+ wTwo <- rTitle
nOne <- rNum
nTwo <- rNum
nThr <- rNum
@@ -45,6 +49,7 @@ oldschool = do
<> show nOne <> show nTwo <> show nThr <> show nFou
<> pure sOne)
+-- A completely random selection of characters supported by Purr generation
gibberish :: Int -> Random Password
gibberish i = go i (return "")
where
@@ -61,8 +66,8 @@ rWord = rIndex wordList
rSym :: Random Char
rSym = rIndex validSymbols
-rCamel :: Random String
-rCamel = camelCase <$> rWord
+rTitle :: Random String
+rTitle = titleCase <$> rWord
wordList :: [String]
wordList = lines $(embedStringFile "data/assets/wordlist.txt")
diff --git a/src/Feature/Generation/Shared.hs b/src/Feature/Generation/Shared.hs
@@ -3,10 +3,12 @@ module Feature.Generation.Shared where
import Data.Char (intToDigit, toLower, toUpper)
import System.Random (randomRIO)
+-- Take a list of anything and return a random element from it
rIndex :: [a] -> IO a
rIndex arr = randomRIO (0, length arr - 1)
>>= (\i -> return $ arr !! i)
+-- Return the input Char randomly uppercased or lowercased
rCap :: Char -> IO Char
rCap c = rIndex [True,False] >>= (\r -> return $ rCap' r c)
where
@@ -14,16 +16,20 @@ rCap c = rIndex [True,False] >>= (\r -> return $ rCap' r c)
rCap' True c = toUpper c
rCap' False c = toLower c
+-- Return a random character from validChars with random capitalization applied
rChar :: IO Char
rChar = rIndex validChars >>= rCap
+-- Return a random character or symbol with random capitalization applied
rCharSym :: IO Char
rCharSym = rIndex (validChars <> validSymbols)>>= rCap
-camelCase :: [Char] -> [Char]
-camelCase [] = []
-camelCase x = toUpper (head x) : map toLower (tail x)
+-- Takes any string and returns it in Titlecase
+titleCase :: [Char] -> [Char]
+titleCase [] = []
+titleCase x = toUpper (head x) : map toLower (tail x)
+-- List of valid characters consisting of latin alphabet and numbers
validChars :: [Char]
validChars = validLetters <> fmap intToDigit validNumbers
diff --git a/src/Feature/Sharing/HTTP.hs b/src/Feature/Sharing/HTTP.hs
@@ -17,10 +17,9 @@ import Web.Scotty
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
-
+-- Routes related to secret sharing functionality
routes :: PurrApp ()
routes = do
-
get "/pw/:id" $ do
reqId <- param "id"
email <- liftIO adminEmail
diff --git a/src/Feature/Sharing/SQLite.hs b/src/Feature/Sharing/SQLite.hs
@@ -20,58 +20,74 @@ import qualified Data.Text as T
import qualified Data.Text.Encoding as ET
import qualified Data.Text.Lazy as LT
+-- Look up a secret based on the "link" attribute
findByLink :: String -> PurrAction (Maybe T.Text)
findByLink link = do
+ -- Get the encryption key from the filesystem as a ByteString
key <- liftIO encKey
+ -- Start up a connection to the SQLite database
conn <- liftIO $ open dbPath
- res <- liftIO $ query conn "SELECT * from pws WHERE link = ?" (Only (last $ splitOn "/" link))
+ -- Constant containing the results of a query looking for the "link" attribute
+ res <- liftIO $
+ query conn "SELECT * from pws WHERE link = ?"
+ (Only (last $ splitOn "/" link))
+ -- Close the SQLite database connection
liftIO $ close conn
+ -- Pass the encryption key and [SecretEntry] to be unencrypted
readEncryptedSecret key res
readEncryptedSecret :: B.ByteString -> [SecretEntry] -> PurrAction (Maybe T.Text)
-readEncryptedSecret key secret = do
- let secNonce = nonce $ safeHead failedSecret secret
+readEncryptedSecret key [] = return Nothing
+readEncryptedSecret key (secret:_) = do
+ -- Increment the number of views on the secret in the database by one
liftIO $ incViews secret dbPath
+ -- Delete the secret if it's expired
delete <- liftIO $ deleteExpiredSecret secret dbPath
- case secret of
- [] -> return Nothing
- (x:_) -> if (delete)
- then return Nothing
- else return (ET.decodeLatin1 <$> (decryptSecret key secNonce $ decodeSecret x))
- where
- incViews :: [SecretEntry] -> String -> IO ()
- incViews [] _ = return ()
- incViews (secret : _) dbPath = do
- conn <- open dbPath
- execute conn
- "UPDATE pws SET views = views + 1 WHERE link = ?" (Only (link secret))
- close conn
+ if (delete)
+ -- Don't return the secret if it's expired
+ then return Nothing
+ -- Otherwise, try to decrypt and return it
+ else return (ET.decodeLatin1 <$>
+ (decryptSecret key (nonce secret) $ decodeSecret secret))
+ where
+ incViews :: SecretEntry -> String -> IO ()
+ incViews secret dbPath = do
+ conn <- open dbPath
+ execute conn
+ "UPDATE pws SET views = views + 1 WHERE link = ?" (Only (link secret))
+ close conn
--- Returns True if deletion occurs, informing the calling function to not
--- provide the successfully retrieved secret to the requestor.
-deleteExpiredSecret :: [SecretEntry] -> String -> IO Bool
-deleteExpiredSecret [] _ = return False
-deleteExpiredSecret (sec : _) dbPath = do
+deleteExpiredSecret :: SecretEntry -> String -> IO Bool
+deleteExpiredSecret sec dbPath = do
+ -- Get the current Unix Epoch time in seconds
time <- epochTime
+ -- Compare the current time against the secret's initial insertion and lifetime
if ((date sec) + ((life sec) * 86400) < time) || (views sec >= maxViews sec)
+ -- Delete the secret if it's expired and return True for the caller
then deleteSec sec dbPath
+ -- Only return False if the secret is not expired
else return False
- where
- deleteSec :: SecretEntry -> String -> IO Bool
- deleteSec sec dbPath = do
- conn <- open dbPath
- execute conn
- "DELETE FROM pws WHERE link = ?" (Only (link sec))
- close conn
- return True
+ where
+ deleteSec :: SecretEntry -> String -> IO Bool
+ deleteSec sec dbPath = do
+ conn <- open dbPath
+ execute conn
+ "DELETE FROM pws WHERE link = ?" (Only (link sec))
+ close conn
+ return True
insertNewSecret :: T.Text -> Integer -> T.Text -> Integer -> PurrAction ()
insertNewSecret sec life link maxViews = do
key <- liftIO encKey
+ -- Create a new nonce to associate with the secret's encryption
nonce <- liftIO Box.newNonce
+ {- Encrypt the secret; this is a pure function because we seeded RNG at program
+ initialization with "sodiumInit" -}
let encSec = encryptSecret key sec nonce
conn <- liftIO $ open dbPath
+ -- Get the current time to timestamp the secret's initial insertion
time <- liftIO epochTime
+ -- Save the secret to the database
liftIO $ execute conn
"INSERT INTO pws (link, secret, nonce, date, life, views, maxViews) VALUES (?, ?, ?, ?, ?, ?, ?)"
(SecretEntry link (encodeSecret encSec) (CL.encode nonce) time life 0 maxViews)
@@ -94,15 +110,12 @@ decryptSecret k n b = do
case (CL.decode k) of
(Just key) -> case (CL.decode n) of
(Just nonce) -> Box.secretboxOpen key nonce b
+ {- There's no sensible way to fail gracefully if our nonce or secret
+ key can't be decoded. Throw an error so the instance admin can
+ investigate -}
Nothing -> error "Failed to decode nonce"
Nothing -> error "Failed to decode secret key"
+-- Helper function to provide the current Epoch Time in seconds
epochTime :: IO Integer
epochTime = fmap round getPOSIXTime
-
-failedSecret :: SecretEntry
-failedSecret = SecretEntry "fail" "fail" (BSC8.pack "fail") 0 0 0 0
-
-safeHead :: a -> [a] -> a
-safeHead x [] = x
-safeHead x l = head l
diff --git a/src/Lib.hs b/src/Lib.hs
@@ -10,12 +10,22 @@ import GHC.Natural (popCountNatural)
import Prelude hiding (id)
import Web.Scotty
-main :: IO ()
+-- Purr's entrypoint
+main :: IO ()
main = do
- sodiumInit
- Configuration.main
- Configuration.keyFileInit
+ -- Initialize the RNG used for sodium encryption (Saltine library)
+ sodiumInit
+ {- Initialize our dotenv configuration which reads from a .env configuration
+ file unless the PURRNOFILE env var exists already. -}
+ Configuration.main
+ {- Initialize the encryption key file if it doesn't
+ exist yet or use the existing key -}
+ Configuration.keyFileInit
+ {- Initialize our database by ensuring the SQLite file exists
+ and has tables setup as the application expects -}
DB.main
+ {- Get the configured port to run on and start the Scotty webserver app
+ defined in HTTP.app -}
appPortStr <- Configuration.appPort
let appPort = read appPortStr :: Int
scotty appPort HTTP.app
