James/purr
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

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

Browse Source
This commit is contained in:
James Eversole 2024-02-17 07:46:09 -06:00
parent 8545b969f3
commit 5484699565
14 changed files with 131 additions and 130 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitignore vendored
View File

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

5
Purr.cabal
View File

@ -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

0
TODO
View File

6
examples/.env.example Normal file
View File

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

16
examples/config.dhall
View File

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

39
src/Core/Configuration.hs
View File

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

10
src/Core/HTTP.hs
View File

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

15
src/Core/SQLite.hs
View File

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

20
src/Core/Types.hs
View File

@ -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

12
src/Feature/Generation/HTTP.hs
View File

@ -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

4
src/Feature/Generation/Links.hs
View File

@ -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.

26
src/Feature/Sharing/HTTP.hs
View File

@ -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)

80
src/Feature/Sharing/SQLite.hs
View File

@ -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

26
src/Lib.hs
View File

@ -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