diff --git a/src/Core/Configuration.hs b/src/Core/Configuration.hs index a59a9fe..63c6b23 100644 --- 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 index 73ac6b5..e18cbbd 100644 --- 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 index bcb7649..7374b6c 100644 --- 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 index 7e61391..57250b4 100644 --- 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 index 84ea64b..64bd8d3 100644 --- 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 index c4bc9fa..7700b5a 100644 --- 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 index 9f034c5..ca2ce50 100644 --- 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 index c28d48e..7cff58f 100644 --- 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 index e859347..f1b3338 100644 --- 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 index acf4aa1..0d1914c 100644 --- 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 index fca3340..08f23be 100644 --- 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