diff --git a/.gitignore b/.gitignore index c81ff34..06b80ec 100644 --- a/.gitignore +++ b/.gitignore @@ -8,3 +8,5 @@ bin/ *.swp dist* *~ +.env +WD diff --git a/Purr.cabal b/Purr.cabal index 2ad0e4b..5ef9f5d 100644 --- 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 deleted file mode 100644 index e69de29..0000000 diff --git a/examples/.env.example b/examples/.env.example new file mode 100644 index 0000000..a1e7089 --- /dev/null +++ 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 deleted file mode 100644 index d07c402..0000000 --- a/examples/config.dhall +++ /dev/null @@ -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 index d53493e..34efd04 100644 --- 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 - -instance FromDhall DhallConfig - -main :: IO DhallConfig +main :: IO () 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" diff --git a/src/Core/HTTP.hs b/src/Core/HTTP.hs index 9f64ba0..bbdca48 100644 --- 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 index 2b1cd9e..8ef5867 100644 --- 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 index f47d272..7e61391 100644 --- 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 index 8e50078..84ea64b 100644 --- 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 index 856de1f..c4bc9fa 100644 --- 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 index 95115e3..11da604 100644 --- 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 index 3ea8eaa..f9d705d 100644 --- 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 index aca3f90..a55413b 100644 --- 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