Remove Dhall dependency and ReaderT; use dotenv; create encryption key on startup if it doesn't exist

.gitignore

@@ -8,3 +8,5 @@ bin/
 *.swp
 dist*
 *~
+.env
+WD

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

examples/.env.example

@@ -0,0 +1,6 @@
+environment="production"
+applicationHost="localhost"
+applicationPort="3000"
+dbFile="data/Purr.sqlite"
+linkLength="24"
+adminEmail="admin@purr.example.com"

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"
-}

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 ()
-
-instance FromDhall DhallConfig
-
-main :: IO DhallConfig
 main = do
-  input auto "./config.dhall"
+  loadFile defaultConfig
+
+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"
+
+dbPath :: IO String
+dbPath = getEnv "dbFile"
+
+confLinkLength :: IO String
+confLinkLength = getEnv "linkLength"
+
+adminEmail :: IO String
+adminEmail = getEnv "adminEmail"
+
+appPort :: IO String
+appPort = getEnv "applicationPort"

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
+    email <- liftIO adminEmail
-    html $ renderIndex "/" (adminEmail conf)
+    html   $ renderIndex "/" email
 
   get "/style.css" $ do
     setHeader "Content-Type" "text/css"

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 :: IO ()
-main db = do
+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"
+encKey = B.readFile "./data/encryptionKey"
-
-confLinkLength :: PurrAction Int
-confLinkLength = lift ask >>= (\a -> return $ linkLength a)

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 PurrApp    a = ScottyM a
-type PurrAction a = ActionT LT.Text ConfigM 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

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,
+import           Feature.Generation.Passwords 
-                                               suggestedScheme, xkcd)
 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
+    genXkcd      <- liftIO xkcd
-    genOldschool <- liftIO $ oldschool
+    genOldschool <- liftIO oldschool
     genGibberish <- liftIO $ gibberish 18
     html $ renderGen genXkcd genOldschool genGibberish

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.

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"
+    reqId  <- param "id"
-    conf  <- lift ask
+    email  <- liftIO adminEmail
-    html   $ renderIndex reqId (adminEmail conf)
+    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"
+    reqSecret    <- param "newSec"
-    reqDur    <- param "newSecDuration"
+    reqDur       <- param "newSecDuration"
-    reqViews  <- param "newSecViews"
+    reqViews     <- param "newSecViews"
-    cLength   <- confLinkLength
+    cLengthStr   <- liftIO confLinkLength
-    link      <- liftIO $ genLink cLength
+    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)

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           Control.Monad.Trans               (liftIO)
-import           Data.List.Split               (splitOn)
+import           Data.List.Split                   (splitOn)
-import           Data.Maybe                    (listToMaybe, fromMaybe, Maybe(Just))
+import           Data.Maybe                        (listToMaybe, fromMaybe, Maybe(Just))
-import           Data.Time.Clock.POSIX         (getPOSIXTime)
+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
+readEncryptedSecret key secret = do
-  db     <- dbPath
+  db     <- liftIO dbPath
-  let secNonce = nonce $ safeHead failedSecret sec
+  let secNonce = nonce $ safeHead failedSecret secret
-  liftIO $ incViews sec db
+  liftIO $ incViews secret db
-  delete <- liftIO $ deleteExpiredSecret sec db
+  delete <- liftIO $ deleteExpiredSecret secret db
-  let decSec = decryptSecret key secNonce $ decodeSecret $ safeHead failedSecret sec
+  case secret of
-  if (delete)
+    []     -> return Nothing
-    then return Nothing
+    (x:_) -> if (delete) 
-    else return (ET.decodeLatin1 <$> decSec)
+      then return Nothing
+      else return (ET.decodeLatin1 <$> (decryptSecret key secNonce $ decodeSecret x))
     where
       incViews :: [SecretEntry] -> String -> IO ()
       incViews []         _ = return ()
-      incViews (sec : _) db = do
+      incViews (secret : _) db = do
-        conn <- liftIO $ open db
+        conn <- open db
-        liftIO $ execute conn
+        execute conn
-          "UPDATE pws SET views = views + 1 WHERE link = ?" (Only (link sec))
+          "UPDATE pws SET views = views + 1 WHERE link = ?" (Only (link secret))
-        liftIO $ close conn
+        close conn
 
--- Returns True if deletion occurs, informing the caller to not provide
+-- Returns True if deletion occurs, informing the calling function to not 
--- the successfully retrieved secret to the requestor.
+-- 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
+        conn  <- open db
-        liftIO $ execute conn
+        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
 

src/Lib.hs

@@ -1,21 +1,21 @@
 module Lib ( main ) where
 
-import qualified Core.Configuration   as Configuration
+import qualified Core.Configuration            as Configuration
-import qualified Core.HTTP            as HTTP
+import qualified Core.HTTP                     as HTTP
-import qualified Core.SQLite          as DB
+import qualified Core.SQLite                   as DB
 import           Core.Types
 
-import           Control.Monad.Reader (lift, liftIO, runReaderT)
+import           Crypto.Saltine                (sodiumInit)
-import           Crypto.Saltine       (sodiumInit)
+import           GHC.Natural                   (popCountNatural)
-import           GHC.Natural          (popCountNatural)
+import           Prelude                       hiding (id)
-import           Prelude              hiding (id)
+import           Web.Scotty
-import           Web.Scotty.Trans     (scottyT)
 
 main :: IO ()
 main = do
   sodiumInit
-  dhallConf <- liftIO Configuration.main
+  Configuration.keyFileInit
-  DB.main (dbFile dhallConf)
+  Configuration.main
-  scottyT (applicationPort dhallConf) (flip runApp dhallConf) HTTP.app where
+  DB.main
-    runApp :: ConfigM a -> DhallConfig -> IO a
+  appPortStr <- Configuration.appPort
-    runApp m = runReaderT (runConfigM m)
+  let appPort = read appPortStr :: Int
+  scotty appPort HTTP.app