commit 5484699565bc640aa4be907b816aaf9266f8e91d
parent 8545b969f33c7052f27bba65a2ac7828623e6f28
Author: James Eversole <james@eversole.co>
Date: Sat, 17 Feb 2024 07:46:09 -0600
Remove Dhall dependency and ReaderT; use dotenv; create encryption key on startup if it doesn't exist
Diffstat:
14 files changed, 130 insertions(+), 129 deletions(-)
diff --git a/.gitignore b/.gitignore
@@ -8,3 +8,5 @@ bin/
*.swp
dist*
*~
+.env
+WD
diff --git a/Purr.cabal b/Purr.cabal
@@ -5,7 +5,7 @@ version: 0.3.0
description: https://git.eversole.co/Purr
author: James Eversole
maintainer: james@eversole.co
-copyright: 2022 James Eversole
+copyright: James Eversole
license: ISC
license-file: LICENSE
build-type: Simple
@@ -33,7 +33,8 @@ executable Purr
, blaze-html >=0.9.1.0
, bytestring >=0.10.12.1
, containers >=0.6.4.1
- , dhall >=1.40
+ , directory >=1.3.0.0
+ , dotenv >=0.10.0.0
, file-embed ==0.0.15.0
, http-types >=0.12.3
, iso8601-time >=0.1.5
diff --git a/TODO b/TODO
diff --git a/examples/.env.example b/examples/.env.example
@@ -0,0 +1,6 @@
+environment="production"
+applicationHost="localhost"
+applicationPort="3000"
+dbFile="data/Purr.sqlite"
+linkLength="24"
+adminEmail="admin@purr.example.com"
diff --git a/examples/config.dhall b/examples/config.dhall
@@ -1,16 +0,0 @@
--- /config.dhall
-{-
- Default Dhall Configuration for Purr.
- You will need to change all instances of "REPLACEME" with the
- appropriate details. Additionally, you may want to change the
- applicationPort from 3000.
--}
-
-{ environment = "production"
-, applicationHost = "REPLACEME"
-, applicationPort = +3000
-, dbFile = "data/Purr.sqlite"
-, dbKey = "REPLACEME!!!!!"
-, linkLength = +24
-, adminEmail = "james@eversole.co"
-}
diff --git a/src/Core/Configuration.hs b/src/Core/Configuration.hs
@@ -1,11 +1,36 @@
-module Core.Configuration ( main ) where
+module Core.Configuration where
+
+import qualified Data.ByteString as B
import Core.Types
+import Crypto.Saltine.Core.SecretBox (newKey)
+import Crypto.Saltine.Class (encode)
+import Configuration.Dotenv
+import System.Directory (doesFileExist)
+import System.Environment (getEnv)
-import Dhall
+main :: IO ()
+main = do
+ loadFile defaultConfig
-instance FromDhall DhallConfig
+keyFileInit :: IO ()
+keyFileInit = do
+ keyExists <- doesFileExist "./data/encryptionKey"
+ case keyExists of
+ True -> putStrLn "Using existing key"
+ False -> do
+ key <- newKey
+ B.writeFile "./data/encryptionKey" (encode key)
+ putStrLn "Creating new encryption key; any pre-existing DB entries will not decrypt"
-main :: IO DhallConfig
-main = do
- input auto "./config.dhall"
+dbPath :: IO String
+dbPath = getEnv "dbFile"
+
+confLinkLength :: IO String
+confLinkLength = getEnv "linkLength"
+
+adminEmail :: IO String
+adminEmail = getEnv "adminEmail"
+
+appPort :: IO String
+appPort = getEnv "applicationPort"
diff --git a/src/Core/HTTP.hs b/src/Core/HTTP.hs
@@ -1,16 +1,18 @@
module Core.HTTP ( app ) where
+import Core.Configuration (dbPath, adminEmail, confLinkLength)
import Core.Types
import Core.Templates (renderIndex, renderStyle)
import Feature.Generation.HTTP as Generation
import Feature.Sharing.HTTP as Sharing
-import Control.Monad.Reader (ask, lift)
+import Control.Monad.Trans (liftIO)
import Data.Maybe (Maybe (Nothing))
import Network.Wai.Middleware.RequestLogger (logStdoutDev)
import Network.Wai.Middleware.Static
-import Web.Scotty.Trans
+import System.Environment
+import Web.Scotty
app :: PurrApp ()
app = do
@@ -20,8 +22,8 @@ app = do
-- Core Routes
get "/" $ do
- conf <- lift ask
- html $ renderIndex "/" (adminEmail conf)
+ email <- liftIO adminEmail
+ html $ renderIndex "/" email
get "/style.css" $ do
setHeader "Content-Type" "text/css"
diff --git a/src/Core/SQLite.hs b/src/Core/SQLite.hs
@@ -1,16 +1,17 @@
module Core.SQLite where
+import Core.Configuration
import Core.Types
-import Control.Monad.Reader (ask, lift, liftIO)
import Data.ByteString as B
import Database.SQLite.Simple
import Database.SQLite.Simple.FromRow
import qualified Data.Text as T
-main :: String -> IO ()
-main db = do
+main :: IO ()
+main = do
+ db <- dbPath
conn <- open db
execute_ conn
"CREATE TABLE IF NOT EXISTS pws\
@@ -23,11 +24,5 @@ main db = do
\ maxViews INT)"
close conn
-dbPath :: PurrAction String
-dbPath = lift ask >>= (\a -> return $ dbFile a)
-
encKey :: IO ByteString
-encKey = B.readFile "./data/key"
-
-confLinkLength :: PurrAction Int
-confLinkLength = lift ask >>= (\a -> return $ linkLength a)
+encKey = B.readFile "./data/encryptionKey"
diff --git a/src/Core/Types.hs b/src/Core/Types.hs
@@ -3,23 +3,18 @@ module Core.Types where
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import Data.ByteString as B
-import Control.Monad.Reader (MonadIO, MonadReader, ReaderT)
import Data.Text
import Database.SQLite.Simple (ToRow)
import Database.SQLite.Simple.FromRow (FromRow)
import GHC.Generics (Generic)
import Numeric.Natural (Natural)
import Text.Blaze.Html
-import Web.Scotty.Trans (ActionT, ScottyT)
+import Web.Scotty (ActionM, ScottyM)
-type PurrApp a = ScottyT LT.Text ConfigM a
-type PurrAction a = ActionT LT.Text ConfigM a
+type PurrApp a = ScottyM a
+type PurrAction a = ActionM a
type Random a = IO a
-newtype ConfigM a = ConfigM
- { runConfigM :: ReaderT DhallConfig IO a
- } deriving (Applicative, Functor, Monad, MonadIO, MonadReader DhallConfig)
-
newtype Password = Password' String
deriving (Eq, Ord)
@@ -29,15 +24,6 @@ newtype UserSecret = UserSecret' String
newtype GenLink = GenLink' String
deriving (Eq, Ord)
-data DhallConfig = DhallConfig
- { environment :: String
- , applicationHost :: String
- , applicationPort :: Int
- , dbFile :: String
- , linkLength :: Int
- , adminEmail :: String
- } deriving (Generic, Show)
-
data SecretEntry = SecretEntry
{ link :: T.Text
, secret :: T.Text
diff --git a/src/Feature/Generation/HTTP.hs b/src/Feature/Generation/HTTP.hs
@@ -3,23 +3,21 @@ module Feature.Generation.HTTP ( routes ) where
import Core.Templates (renderIndex)
import Core.Types
-import Feature.Generation.Passwords (gibberish, oldschool,
- suggestedScheme, xkcd)
+import Feature.Generation.Passwords
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 Control.Monad.Trans (liftIO)
import Data.Maybe (listToMaybe)
import Prelude
-import Web.Scotty.Trans
+import Web.Scotty
routes :: PurrApp ()
routes = do
-
get "/gen" $ do
- genXkcd <- liftIO $ xkcd
- genOldschool <- liftIO $ oldschool
+ genXkcd <- liftIO xkcd
+ genOldschool <- liftIO oldschool
genGibberish <- liftIO $ gibberish 18
html $ renderGen genXkcd genOldschool genGibberish
diff --git a/src/Feature/Generation/Links.hs b/src/Feature/Generation/Links.hs
@@ -1,10 +1,8 @@
module Feature.Generation.Links ( genLink ) where
import Core.Types
-import Feature.Generation.Shared (rChar, rIndex, validChars)
-
-import Control.Monad.Reader (ask, lift)
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.
diff --git a/src/Feature/Sharing/HTTP.hs b/src/Feature/Sharing/HTTP.hs
@@ -1,6 +1,6 @@
module Feature.Sharing.HTTP ( routes ) where
-import Core.SQLite (confLinkLength)
+import Core.Configuration (dbPath, adminEmail, confLinkLength)
import Core.Templates (renderIndex)
import Core.Types
@@ -8,11 +8,12 @@ import Feature.Generation.Links (genLink)
import Feature.Sharing.SQLite (findByLink, insertNewSecret)
import Feature.Sharing.Templates (renderPw)
-import Control.Monad.Reader (ask, lift, liftIO)
+import Control.Monad.Trans (liftIO)
import Data.List.Split (splitOn)
import Data.Maybe (listToMaybe)
import Prelude
-import Web.Scotty.Trans
+import System.Environment
+import Web.Scotty
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
@@ -22,9 +23,9 @@ routes :: PurrApp ()
routes = do
get "/pw/:id" $ do
- reqId <- param "id"
- conf <- lift ask
- html $ renderIndex reqId (adminEmail conf)
+ reqId <- param "id"
+ email <- liftIO adminEmail
+ html $ renderIndex reqId email
post "/pw" $ do
reqId <- param "userLink"
@@ -32,10 +33,11 @@ routes = do
html $ renderPw (last $ splitOn "/" reqId) res
post "/new" $ do
- reqSecret <- param "newSec"
- reqDur <- param "newSecDuration"
- reqViews <- param "newSecViews"
- cLength <- confLinkLength
- link <- liftIO $ genLink cLength
+ reqSecret <- param "newSec"
+ reqDur <- param "newSecDuration"
+ reqViews <- param "newSecViews"
+ cLengthStr <- liftIO confLinkLength
+ let cLength = read cLengthStr :: Int
+ link <- liftIO $ genLink cLength
insertNewSecret reqSecret reqDur (T.pack $ show link) reqViews
- html $ renderPw (show link) (Just reqSecret)
+ html $ renderPw (show link) (Just reqSecret)
diff --git a/src/Feature/Sharing/SQLite.hs b/src/Feature/Sharing/SQLite.hs
@@ -1,13 +1,14 @@
module Feature.Sharing.SQLite where
+import Core.Configuration
import Core.SQLite
import Core.Types
-import Feature.Generation.Passwords (Password)
+import Feature.Generation.Passwords (Password)
-import Control.Monad.Reader (ask, lift, liftIO)
-import Data.List.Split (splitOn)
-import Data.Maybe (listToMaybe, fromMaybe, Maybe(Just))
-import Data.Time.Clock.POSIX (getPOSIXTime)
+import Control.Monad.Trans (liftIO)
+import Data.List.Split (splitOn)
+import Data.Maybe (listToMaybe, fromMaybe, Maybe(Just))
+import Data.Time.Clock.POSIX (getPOSIXTime)
import Database.SQLite.Simple
import qualified Crypto.Saltine.Core.SecretBox as Box
@@ -21,63 +22,64 @@ import qualified Data.Text.Lazy as LT
findByLink :: String -> PurrAction (Maybe T.Text)
findByLink link = do
- db <- dbPath
+ db <- liftIO dbPath
key <- liftIO encKey
conn <- liftIO $ open db
res <- liftIO $ query conn "SELECT * from pws WHERE link = ?" (Only (last $ splitOn "/" link))
liftIO $ close conn
readEncryptedSecret key res
-insertNewSecret :: T.Text -> Integer -> T.Text -> Integer -> PurrAction ()
-insertNewSecret sec life link maxViews = do
- db <- dbPath
- key <- liftIO encKey
- nonce <- liftIO $ Box.newNonce
- let encSec = encryptSecret key sec nonce
- conn <- liftIO $ open db
- time <- liftIO $ epochTime
- 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)
- liftIO $ close conn
-
readEncryptedSecret :: B.ByteString -> [SecretEntry] -> PurrAction (Maybe T.Text)
-readEncryptedSecret key sec = do
- db <- dbPath
- let secNonce = nonce $ safeHead failedSecret sec
- liftIO $ incViews sec db
- delete <- liftIO $ deleteExpiredSecret sec db
- let decSec = decryptSecret key secNonce $ decodeSecret $ safeHead failedSecret sec
- if (delete)
- then return Nothing
- else return (ET.decodeLatin1 <$> decSec)
+readEncryptedSecret key secret = do
+ db <- liftIO dbPath
+ let secNonce = nonce $ safeHead failedSecret secret
+ liftIO $ incViews secret db
+ delete <- liftIO $ deleteExpiredSecret secret db
+ 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 (sec : _) db = do
- conn <- liftIO $ open db
- liftIO $ execute conn
- "UPDATE pws SET views = views + 1 WHERE link = ?" (Only (link sec))
- liftIO $ close conn
+ incViews (secret : _) db = do
+ conn <- open db
+ execute conn
+ "UPDATE pws SET views = views + 1 WHERE link = ?" (Only (link secret))
+ close conn
--- Returns True if deletion occurs, informing the caller to not provide
--- the successfully retrieved secret to the requestor.
+-- 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 : _) db = do
- time <- liftIO $ epochTime
+ time <- epochTime
if ((date sec) + ((life sec) * 86400) < time) || (views sec >= maxViews sec)
then deleteSec sec db
else return False
where
deleteSec :: SecretEntry -> String -> IO Bool
deleteSec sec db = do
- conn <- liftIO $ open db
- liftIO $ execute conn
+ conn <- open db
+ execute conn
"DELETE FROM pws WHERE link = ?" (Only (link sec))
- liftIO $ close conn
+ close conn
return True
+insertNewSecret :: T.Text -> Integer -> T.Text -> Integer -> PurrAction ()
+insertNewSecret sec life link maxViews = do
+ db <- liftIO dbPath
+ key <- liftIO encKey
+ nonce <- liftIO Box.newNonce
+ let encSec = encryptSecret key sec nonce
+ conn <- liftIO $ open db
+ time <- liftIO epochTime
+ 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)
+ liftIO $ close conn
+
encodeSecret :: B.ByteString -> T.Text
encodeSecret b = ET.decodeUtf8 $ B64.encode b
diff --git a/src/Lib.hs b/src/Lib.hs
@@ -1,21 +1,21 @@
module Lib ( main ) where
-import qualified Core.Configuration as Configuration
-import qualified Core.HTTP as HTTP
-import qualified Core.SQLite as DB
+import qualified Core.Configuration as Configuration
+import qualified Core.HTTP as HTTP
+import qualified Core.SQLite as DB
import Core.Types
-import Control.Monad.Reader (lift, liftIO, runReaderT)
-import Crypto.Saltine (sodiumInit)
-import GHC.Natural (popCountNatural)
-import Prelude hiding (id)
-import Web.Scotty.Trans (scottyT)
+import Crypto.Saltine (sodiumInit)
+import GHC.Natural (popCountNatural)
+import Prelude hiding (id)
+import Web.Scotty
main :: IO ()
main = do
sodiumInit
- dhallConf <- liftIO Configuration.main
- DB.main (dbFile dhallConf)
- scottyT (applicationPort dhallConf) (flip runApp dhallConf) HTTP.app where
- runApp :: ConfigM a -> DhallConfig -> IO a
- runApp m = runReaderT (runConfigM m)
+ Configuration.keyFileInit
+ Configuration.main
+ DB.main
+ appPortStr <- Configuration.appPort
+ let appPort = read appPortStr :: Int
+ scotty appPort HTTP.app
