Squashed commit of the following:

commit 9aaa5307e7671bc8bcc444733a6e38999f346772
Author: James Eversole <james@eversole.co>
Date:   Mon Jul 18 16:03:43 2022 -0500

    Completed migration to SQLite, full feature parity with original Mongo/Couch implementations. Added ability to submit new passwords with full frontend functionality. Generation of random links now functions as expected and Unix Epoch Timestamps are now included in DB entries.
This commit is contained in:
James Eversole 2022-07-18 16:04:10 -05:00
parent 6a0b5b0144
commit 1718e69533
16 changed files with 156 additions and 219 deletions

View File

@ -20,12 +20,14 @@ extra-source-files:
library library
exposed-modules: exposed-modules:
Core.Configuration Core.Configuration
Core.Couch
Core.HTTP Core.HTTP
Core.SQLite
Core.Templates Core.Templates
Core.Types Core.Types
Feature.Sharing.Couch Feature.Generation.Links
Feature.Generation.Shared
Feature.Sharing.HTTP Feature.Sharing.HTTP
Feature.Sharing.SQLite
Feature.Sharing.Templates Feature.Sharing.Templates
Feature.Sharing.Types Feature.Sharing.Types
Lib Lib
@ -42,18 +44,17 @@ library
OverloadedStrings OverloadedStrings
ScopedTypeVariables ScopedTypeVariables
build-depends: build-depends:
aeson >=2.0.0.0 base >=4.7
, base >=4.7
, blaze-html >=0.9.1.0 , blaze-html >=0.9.1.0
, bytestring
, containers , containers
, dhall >=1.40 && <1.41.2 , dhall >=1.40 && <1.41.2
, http-types >=0.12.3 , http-types >=0.12.3
, iso8601-time >=0.1.5 , iso8601-time >=0.1.5
, mtl >=2.2.2 , mtl >=2.2.2
, req >=3.10.0 , random >=1.2
, scotty ==0.12 , scotty ==0.12
, shakespeare >=2.0.20 , shakespeare >=2.0.20
, sqlite-simple >=0.4.18.0
, text >=1.2 , text >=1.2
, time >=1.9 , time >=1.9
, wai-extra >=3.1.12.1 , wai-extra >=3.1.12.1
@ -76,18 +77,17 @@ executable Purr-exe
ghc-options: -threaded -rtsopts -with-rtsopts=-N ghc-options: -threaded -rtsopts -with-rtsopts=-N
build-depends: build-depends:
Purr Purr
, aeson >=2.0.0.0
, base >=4.7 , base >=4.7
, blaze-html >=0.9.1.0 , blaze-html >=0.9.1.0
, bytestring
, containers , containers
, dhall >=1.40 && <1.41.2 , dhall >=1.40 && <1.41.2
, http-types >=0.12.3 , http-types >=0.12.3
, iso8601-time >=0.1.5 , iso8601-time >=0.1.5
, mtl >=2.2.2 , mtl >=2.2.2
, req >=3.10.0 , random >=1.2
, scotty ==0.12 , scotty ==0.12
, shakespeare >=2.0.20 , shakespeare >=2.0.20
, sqlite-simple >=0.4.18.0
, text >=1.2 , text >=1.2
, time >=1.9 , time >=1.9
, wai-extra >=3.1.12.1 , wai-extra >=3.1.12.1
@ -111,18 +111,17 @@ test-suite Purr-test
ghc-options: -threaded -rtsopts -with-rtsopts=-N ghc-options: -threaded -rtsopts -with-rtsopts=-N
build-depends: build-depends:
Purr Purr
, aeson >=2.0.0.0
, base >=4.7 , base >=4.7
, blaze-html >=0.9.1.0 , blaze-html >=0.9.1.0
, bytestring
, containers , containers
, dhall >=1.40 && <1.41.2 , dhall >=1.40 && <1.41.2
, http-types >=0.12.3 , http-types >=0.12.3
, iso8601-time >=0.1.5 , iso8601-time >=0.1.5
, mtl >=2.2.2 , mtl >=2.2.2
, req >=3.10.0 , random >=1.2
, scotty ==0.12 , scotty ==0.12
, shakespeare >=2.0.20 , shakespeare >=2.0.20
, sqlite-simple >=0.4.18.0
, text >=1.2 , text >=1.2
, time >=1.9 , time >=1.9
, wai-extra >=3.1.12.1 , wai-extra >=3.1.12.1

View File

@ -13,7 +13,7 @@ You shouldn't! This is [free and open-source software](https://git.eversole.co/J
## Tech Stack? ## Tech Stack?
1. [Haskell](https://www.haskell.org) and [Scotty](https://github.com/scotty-web/scotty) backend. 1. [Haskell](https://www.haskell.org) and [Scotty](https://github.com/scotty-web/scotty) backend.
2. [HTMX](https://github.com/bigskysoftware/htmx) for the frontend. 2. [HTMX](https://github.com/bigskysoftware/htmx) for the frontend.
3. [CouchDB](https://gitbox.apache.org/repos/asf?p=couchdb.git) database. 3. [SQLite](https://github.com/sqlite/sqlite) database.
## Project Goals ## Project Goals
1. Provide a minimal and clean interface for generating and sharing passwords. 1. Provide a minimal and clean interface for generating and sharing passwords.

View File

@ -28,18 +28,17 @@ default-extensions:
description: https://git.eversole.co/James/Purr description: https://git.eversole.co/James/Purr
dependencies: dependencies:
- aeson >= 2.0.0.0
- base >= 4.7 - base >= 4.7
- blaze-html >= 0.9.1.0 - blaze-html >= 0.9.1.0
- bytestring
- containers - containers
- dhall >= 1.40 && < 1.41.2 - dhall >= 1.40 && < 1.41.2
- http-types >= 0.12.3 - http-types >= 0.12.3
- iso8601-time >= 0.1.5 - iso8601-time >= 0.1.5
- mtl >= 2.2.2 - mtl >= 2.2.2
- req >= 3.10.0 - random >= 1.2
- scotty == 0.12 - scotty == 0.12
- shakespeare >= 2.0.20 - shakespeare >= 2.0.20
- sqlite-simple >= 0.4.18.0
- time >= 1.9 - time >= 1.9
- text >= 1.2 - text >= 1.2
- wai-extra >= 3.1.12.1 - wai-extra >= 3.1.12.1

View File

@ -1,79 +0,0 @@
module Core.Couch where
import Core.Types
import Control.Monad.Reader (MonadIO, lift, ask)
import Data.Aeson
import Network.HTTP.Req as Req
import qualified Data.Text as T
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as LB
getAllDBs :: PurrAction LbsResponse
getAllDBs = do
host <- dbHost
user <- dbUser
pw <- dbPassword
req
GET
(http host /: "_all_dbs")
NoReqBody
lbsResponse $
basicAuthUnsafe user pw
<>
Req.port 5984
createDB :: (FromJSON a) => T.Text -> PurrAction (JsonResponse a)
createDB dbName = do
host <- dbHost
user <- dbUser
pw <- dbPassword
req
PUT
(http host /: dbName)
NoReqBody
jsonResponse $
basicAuthUnsafe user pw
<>
Req.port 5984
getAllDocs :: PurrAction LbsResponse
getAllDocs = do
host <- dbHost
dbName <- confDb
user <- dbUser
pw <- dbPassword
req
GET
(http host /: dbName)
NoReqBody
lbsResponse $
basicAuthUnsafe user pw
<>
Req.port 5984
confDb :: PurrAction T.Text
confDb = do
conf <- lift ask
return $ T.pack $ dataDB conf
dbHost :: PurrAction T.Text
dbHost = do
conf <- lift ask
return $ T.pack $ couchHost conf
dbPort :: PurrAction Int
dbPort = do
conf <- lift ask
return $ couchPort conf
dbPassword :: PurrAction B.ByteString
dbPassword = do
conf <- lift ask
return $ B.pack $ couchPassword conf
dbUser :: PurrAction B.ByteString
dbUser = do
conf <- lift ask
return $ B.pack $ couchUsername conf

24
src/Core/SQLite.hs Normal file
View File

@ -0,0 +1,24 @@
module Core.SQLite where
import Core.Types
import Control.Monad.Reader (ask, lift, liftIO)
import Database.SQLite.Simple
import Database.SQLite.Simple.FromRow
import qualified Data.Text as T
main :: String -> IO ()
main db = do
conn <- open db
execute_ conn
"CREATE TABLE IF NOT EXISTS pws\
\ (link TEXT PRIMARY KEY,\
\ secret TEXT,\
\ date DATETIME DEFAULT CURRENT_TIMESTAMP)"
close conn
dbPath :: PurrAction String
dbPath = do
conf <- lift ask
return $ dbFile conf

View File

@ -3,16 +3,18 @@
module Core.Templates ( renderIndex, renderStyle ) where module Core.Templates ( renderIndex, renderStyle ) where
import Data.Text.Lazy (Text)
import Text.Blaze.Html.Renderer.Text (renderHtml) import Text.Blaze.Html.Renderer.Text (renderHtml)
import Text.Blaze.Html import Text.Blaze.Html
import Text.Cassius (cassiusFile, renderCss) import Text.Cassius (cassiusFile, renderCss)
import Text.Hamlet (shamletFile) import Text.Hamlet (shamletFile)
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import Prelude import Prelude
renderIndex :: String -> Maybe String -> Text renderIndex :: String -> Maybe T.Text -> LT.Text
renderIndex link password = renderHtml ( $(shamletFile "./views/index.hamlet") ) renderIndex link password = renderHtml ( $(shamletFile "./views/index.hamlet") )
renderStyle :: Text renderStyle :: LT.Text
renderStyle = renderCss ( $(cassiusFile "./views/cassius/style.cassius") "/style.css" ) renderStyle = renderCss ( $(cassiusFile "./views/cassius/style.cassius") "/style.css" )

View File

@ -5,7 +5,6 @@ import qualified Data.Text.Lazy as LT
import Control.Monad.Reader (MonadIO, MonadReader, ReaderT) import Control.Monad.Reader (MonadIO, MonadReader, ReaderT)
import Data.Text import Data.Text
import GHC.Generics (Generic) import GHC.Generics (Generic)
import Network.HTTP.Req (HttpException, MonadHttp, handleHttpException)
import Numeric.Natural (Natural) import Numeric.Natural (Natural)
import Web.Scotty.Trans (ScottyT, ActionT) import Web.Scotty.Trans (ScottyT, ActionT)
@ -16,17 +15,9 @@ newtype ConfigM a = ConfigM
{ runConfigM :: ReaderT DhallConfig IO a { runConfigM :: ReaderT DhallConfig IO a
} deriving (Applicative, Functor, Monad, MonadIO, MonadReader DhallConfig) } deriving (Applicative, Functor, Monad, MonadIO, MonadReader DhallConfig)
instance MonadHttp (ActionT LT.Text ConfigM) where
handleHttpException = error . show
data DhallConfig = DhallConfig data DhallConfig = DhallConfig
{ environment :: String { environment :: String
, applicationHost :: String , applicationHost :: String
, applicationPort :: Int , applicationPort :: Int
, couchHost :: String , dbFile :: String
, couchPort :: Int
, couchUsername :: String
, couchPassword :: String
, adminDB :: String
, dataDB :: String
} deriving (Generic, Show) } deriving (Generic, Show)

View File

@ -0,0 +1,34 @@
module Feature.Generation.Links ( genLink ) where
import Core.Types
import Feature.Generation.Shared (rIndex)
import Control.Monad.Reader (ask, lift, liftIO)
import Data.Char (toLower, toUpper)
import Data.List (foldl')
import System.IO
import System.Random
genLink :: Int -> [Char] -> IO [Char]
genLink 0 cs = return cs
genLink d cs = do
res <- rChar
fin <- rCap res
genLink (d - 1) (cs <> (fin:[]))
validChars :: [Char]
validChars = ['a'..'z'] <> ['1'..'9']
rChar :: IO Char
rChar = rIndex validChars
rCap :: Char -> IO Char -- rCap takes a single character and returns it
rCap c = do -- capitalized or lowercased at random.
capRand <- randomRIO (0,1)
return $ checkRand capRand c
where
checkRand :: Int -> Char -> Char
checkRand r c
| r == 0 = toLower c
| r == 1 = toUpper c
| otherwise = c

View File

@ -0,0 +1,8 @@
module Feature.Generation.Shared where
import System.Random (randomRIO)
rIndex :: [a] -> IO a
rIndex arr = do
i <- randomRIO (0, length arr - 1)
return $ arr !! i

View File

@ -1,78 +0,0 @@
module Feature.Sharing.Couch where
import Core.Types
import Core.Couch (confDb, dbHost, dbPort, dbPassword, dbUser)
import Feature.Sharing.Types
import Control.Monad.Reader (MonadIO, lift, ask)
import Data.Aeson
import Data.Maybe (fromJust)
import Data.Text.Encoding
import Network.HTTP.Req as Req
import qualified Data.Text as T
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as LB
findByLink :: String -> PurrAction FindResults
findByLink link = do
host <- dbHost
dbName <- confDb
dbPort <- dbPort
user <- dbUser
pw <- dbPassword
res <- req
POST
(http host /: dbName /: "_find")
(ReqBodyJson postBody)
jsonResponse $
basicAuthUnsafe user pw
<>
Req.port dbPort
return $ responseBody res
where
postBody :: Maybe Object
postBody = decodeStrict $ encodeUtf8 $
"{\"selector\": {\"link\": {\"$eq\": \"" <> sanitizeQ link <> "\"}}}"
{-
createNewSecret :: String -> PurrAction ()
createNewSecret sec = do
host <- dbHost
dbName <- confDb
dbPort <- dbPort
user <- dbUser
pw <- dbPassword
res <- req
POST
(http host /: dbName)
(ReqBodyJson postBody)
jsonResponse $
basicAuthUnsafe user pw
<>
Req.port dbPort
return $ responseBody res
where
postBody :: SecretEntry
postBody = SecretEntry
Nothing
Nothing
"notImplementedYet"
"zedNotImplementedYet"
sec
-}
findToSecret :: FindResults -> Maybe String
findToSecret doc = lookupSecret $ docs doc
where
lookupSecret :: [SecretEntry] -> Maybe String
lookupSecret [] = Nothing
lookupSecret (x:xs) = Just (secret x)
sanitizeQ :: String -> T.Text
sanitizeQ s = T.pack $ map sanitizeQ' s
where
sanitizeQ' :: Char -> Char
sanitizeQ' '"' = ' '
sanitizeQ' '\\' = ' '
sanitizeQ' c = c

View File

@ -3,13 +3,16 @@ module Feature.Sharing.HTTP ( routes ) where
import Core.Types import Core.Types
import Core.Templates (renderIndex) import Core.Templates (renderIndex)
import Feature.Generation.Links (genLink)
import Feature.Sharing.SQLite (findByLink, insertNewSecret)
import Feature.Sharing.Templates (renderPw) import Feature.Sharing.Templates (renderPw)
import Feature.Sharing.Couch (findByLink, findToSecret) import Feature.Sharing.Types
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy as LT
import Control.Monad.Reader (ask, lift) import Control.Monad.Reader (ask, lift, liftIO)
import Data.Maybe (listToMaybe)
import Web.Scotty.Trans import Web.Scotty.Trans
import Prelude import Prelude
@ -17,11 +20,17 @@ routes :: PurrApp ()
routes = do routes = do
get "/pw/:id" $ do get "/pw/:id" $ do
reqId <- param "id" reqId <- param "id"
secretRes <- findByLink reqId res <- findByLink reqId
html $ renderIndex reqId (findToSecret secretRes) html $ renderIndex reqId (secret <$> res)
post "/pw" $ do post "/pw" $ do
reqId <- param "userLink" reqId <- param "userLink"
secretRes <- findByLink reqId res <- findByLink reqId
html $ renderPw reqId (findToSecret secretRes) html $ renderPw reqId (secret <$> res)
post "/new" $ do
reqSecret <- param "newSec"
link <- liftIO $ genLink 24 ""
insertNewSecret reqSecret (T.pack link)
html $ renderPw link (Just reqSecret)

View File

@ -0,0 +1,35 @@
module Feature.Sharing.SQLite where
import Core.Types
import Core.SQLite
import Feature.Sharing.Types
import Control.Monad.Reader (ask, lift, liftIO)
import Data.Maybe (listToMaybe)
import Data.Time.Clock.POSIX (getPOSIXTime)
import Database.SQLite.Simple
import Database.SQLite.Simple.FromRow
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
findByLink :: String -> PurrAction (Maybe SecretEntry)
findByLink link = do
db <- dbPath
conn <- liftIO $ open db
res <- liftIO $ query conn "SELECT * from pws WHERE link = ?" (Only link)
liftIO $ close conn
return $ listToMaybe res
insertNewSecret :: T.Text -> T.Text -> PurrAction ()
insertNewSecret sec link = do
db <- dbPath
conn <- liftIO $ open db
time <- liftIO $ epochTime
liftIO $ execute conn
"INSERT INTO pws (link, secret, date) VALUES (?, ?, ?)"
(SecretEntry link sec time)
liftIO $ close conn
epochTime :: IO Integer
epochTime = fmap round getPOSIXTime

View File

@ -3,6 +3,7 @@
module Feature.Sharing.Templates ( renderPw ) where module Feature.Sharing.Templates ( renderPw ) where
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy as LT
import Text.Blaze.Html.Renderer.Text (renderHtml) import Text.Blaze.Html.Renderer.Text (renderHtml)
@ -11,5 +12,5 @@ import Text.Hamlet (shamletFile)
import Prelude import Prelude
renderPw :: String -> Maybe String -> LT.Text renderPw :: String -> Maybe T.Text -> LT.Text
renderPw link password = renderHtml ( $(shamletFile "./views/pw.hamlet") ) renderPw link password = renderHtml ( $(shamletFile "./views/pw.hamlet") )

View File

@ -1,28 +1,19 @@
module Feature.Sharing.Types where module Feature.Sharing.Types where
import Data.Aeson
import Data.Map.Strict (Map) import Data.Map.Strict (Map)
import Data.Typeable (Typeable) import Data.Typeable (Typeable)
import GHC.Generics import GHC.Generics
data SecretEntry = SecretEntry import Database.SQLite.Simple
{ _id :: Maybe String import Database.SQLite.Simple.FromRow
, _rev :: Maybe String
, creationTime :: String
, link :: String
, secret :: String
} deriving (Generic, Show, Typeable)
data FindResults = FindResults import qualified Data.Text as T
{ bookmark :: String
, docs :: [SecretEntry]
, warning :: Maybe String
} deriving (Generic, Show, Typeable)
instance ToJSON SecretEntry where data SecretEntry = SecretEntry
toEncoding = genericToEncoding defaultOptions { link :: T.Text
instance ToJSON FindResults where , secret :: T.Text
toEncoding = genericToEncoding defaultOptions , date :: Integer
} deriving (Show, Generic)
instance FromJSON SecretEntry instance FromRow SecretEntry where
instance FromJSON FindResults instance ToRow SecretEntry where

View File

@ -2,10 +2,10 @@ 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.Couch as DB import qualified Core.SQLite as DB
import Core.Types import Core.Types
import Control.Monad.Reader (liftIO, runReaderT) import Control.Monad.Reader (lift, liftIO, runReaderT)
import GHC.Natural (popCountNatural) import GHC.Natural (popCountNatural)
import Prelude hiding (id) import Prelude hiding (id)
import Web.Scotty.Trans (scottyT) import Web.Scotty.Trans (scottyT)
@ -13,6 +13,7 @@ import Web.Scotty.Trans (scottyT)
main :: IO () main :: IO ()
main = do main = do
dhallConf <- liftIO Configuration.main dhallConf <- liftIO Configuration.main
DB.main (dbFile dhallConf)
scottyT (applicationPort dhallConf) (flip runApp dhallConf) HTTP.app where scottyT (applicationPort dhallConf) (flip runApp dhallConf) HTTP.app where
runApp :: ConfigM a -> DhallConfig -> IO a runApp :: ConfigM a -> DhallConfig -> IO a
runApp m = runReaderT (runConfigM m) runApp m = runReaderT (runConfigM m)

View File

@ -30,15 +30,15 @@ $doctype 5
<div #shareNew .shareNew> <div #shareNew .shareNew>
<p> <p>
<input .mainInput <input .mainInput
name="newPw" name="newSec"
type="text" type="text"
placeholder="Enter a Secret to Share" placeholder="Enter a Secret to Share"
/> />
<button .mainButton <button .mainButton
hx-post="/newpw" hx-post="/new"
hx-target="#requestedPw" hx-target="#requestedPw"
hx-swap="outerHTML" hx-swap="outerHTML"
hx-include="[name='newPw']" hx-include="[name='newSec']"
/> />
Share Secret Share Secret