commit 1718e69533788cbfef4144a38bd7ae9b67a3df9e
parent 6a0b5b014499af788951b8a3e16b8eb0b0b5b2b9
Author: James Eversole <james@eversole.co>
Date: Mon, 18 Jul 2022 16:04:10 -0500
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.
Diffstat:
16 files changed, 156 insertions(+), 219 deletions(-)
diff --git a/Purr.cabal b/Purr.cabal
@@ -20,12 +20,14 @@ extra-source-files:
library
exposed-modules:
Core.Configuration
- Core.Couch
Core.HTTP
+ Core.SQLite
Core.Templates
Core.Types
- Feature.Sharing.Couch
+ Feature.Generation.Links
+ Feature.Generation.Shared
Feature.Sharing.HTTP
+ Feature.Sharing.SQLite
Feature.Sharing.Templates
Feature.Sharing.Types
Lib
@@ -42,18 +44,17 @@ library
OverloadedStrings
ScopedTypeVariables
build-depends:
- aeson >=2.0.0.0
- , base >=4.7
+ base >=4.7
, blaze-html >=0.9.1.0
- , bytestring
, containers
, dhall >=1.40 && <1.41.2
, http-types >=0.12.3
, iso8601-time >=0.1.5
, mtl >=2.2.2
- , req >=3.10.0
+ , random >=1.2
, scotty ==0.12
, shakespeare >=2.0.20
+ , sqlite-simple >=0.4.18.0
, text >=1.2
, time >=1.9
, wai-extra >=3.1.12.1
@@ -76,18 +77,17 @@ executable Purr-exe
ghc-options: -threaded -rtsopts -with-rtsopts=-N
build-depends:
Purr
- , aeson >=2.0.0.0
, base >=4.7
, blaze-html >=0.9.1.0
- , bytestring
, containers
, dhall >=1.40 && <1.41.2
, http-types >=0.12.3
, iso8601-time >=0.1.5
, mtl >=2.2.2
- , req >=3.10.0
+ , random >=1.2
, scotty ==0.12
, shakespeare >=2.0.20
+ , sqlite-simple >=0.4.18.0
, text >=1.2
, time >=1.9
, wai-extra >=3.1.12.1
@@ -111,18 +111,17 @@ test-suite Purr-test
ghc-options: -threaded -rtsopts -with-rtsopts=-N
build-depends:
Purr
- , aeson >=2.0.0.0
, base >=4.7
, blaze-html >=0.9.1.0
- , bytestring
, containers
, dhall >=1.40 && <1.41.2
, http-types >=0.12.3
, iso8601-time >=0.1.5
, mtl >=2.2.2
- , req >=3.10.0
+ , random >=1.2
, scotty ==0.12
, shakespeare >=2.0.20
+ , sqlite-simple >=0.4.18.0
, text >=1.2
, time >=1.9
, wai-extra >=3.1.12.1
diff --git a/README.md b/README.md
@@ -13,7 +13,7 @@ You shouldn't! This is [free and open-source software](https://git.eversole.co/J
## Tech Stack?
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.
-3. [CouchDB](https://gitbox.apache.org/repos/asf?p=couchdb.git) database.
+3. [SQLite](https://github.com/sqlite/sqlite) database.
## Project Goals
1. Provide a minimal and clean interface for generating and sharing passwords.
diff --git a/package.yaml b/package.yaml
@@ -28,18 +28,17 @@ default-extensions:
description: https://git.eversole.co/James/Purr
dependencies:
-- aeson >= 2.0.0.0
- base >= 4.7
- blaze-html >= 0.9.1.0
-- bytestring
- containers
- dhall >= 1.40 && < 1.41.2
- http-types >= 0.12.3
- iso8601-time >= 0.1.5
- mtl >= 2.2.2
-- req >= 3.10.0
+- random >= 1.2
- scotty == 0.12
- shakespeare >= 2.0.20
+- sqlite-simple >= 0.4.18.0
- time >= 1.9
- text >= 1.2
- wai-extra >= 3.1.12.1
diff --git a/src/Core/Couch.hs b/src/Core/Couch.hs
@@ -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
diff --git a/src/Core/SQLite.hs b/src/Core/SQLite.hs
@@ -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
diff --git a/src/Core/Templates.hs b/src/Core/Templates.hs
@@ -3,16 +3,18 @@
module Core.Templates ( renderIndex, renderStyle ) where
-import Data.Text.Lazy (Text)
import Text.Blaze.Html.Renderer.Text (renderHtml)
import Text.Blaze.Html
import Text.Cassius (cassiusFile, renderCss)
import Text.Hamlet (shamletFile)
+import qualified Data.Text as T
+import qualified Data.Text.Lazy as LT
+
import Prelude
-renderIndex :: String -> Maybe String -> Text
+renderIndex :: String -> Maybe T.Text -> LT.Text
renderIndex link password = renderHtml ( $(shamletFile "./views/index.hamlet") )
-renderStyle :: Text
+renderStyle :: LT.Text
renderStyle = renderCss ( $(cassiusFile "./views/cassius/style.cassius") "/style.css" )
diff --git a/src/Core/Types.hs b/src/Core/Types.hs
@@ -5,7 +5,6 @@ import qualified Data.Text.Lazy as LT
import Control.Monad.Reader (MonadIO, MonadReader, ReaderT)
import Data.Text
import GHC.Generics (Generic)
-import Network.HTTP.Req (HttpException, MonadHttp, handleHttpException)
import Numeric.Natural (Natural)
import Web.Scotty.Trans (ScottyT, ActionT)
@@ -16,17 +15,9 @@ newtype ConfigM a = ConfigM
{ runConfigM :: ReaderT DhallConfig IO a
} deriving (Applicative, Functor, Monad, MonadIO, MonadReader DhallConfig)
-instance MonadHttp (ActionT LT.Text ConfigM) where
- handleHttpException = error . show
-
data DhallConfig = DhallConfig
{ environment :: String
, applicationHost :: String
, applicationPort :: Int
- , couchHost :: String
- , couchPort :: Int
- , couchUsername :: String
- , couchPassword :: String
- , adminDB :: String
- , dataDB :: String
+ , dbFile :: String
} deriving (Generic, Show)
diff --git a/src/Feature/Generation/Links.hs b/src/Feature/Generation/Links.hs
@@ -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
diff --git a/src/Feature/Generation/Shared.hs b/src/Feature/Generation/Shared.hs
@@ -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
diff --git a/src/Feature/Sharing/Couch.hs b/src/Feature/Sharing/Couch.hs
@@ -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
diff --git a/src/Feature/Sharing/HTTP.hs b/src/Feature/Sharing/HTTP.hs
@@ -3,13 +3,16 @@ module Feature.Sharing.HTTP ( routes ) where
import Core.Types
import Core.Templates (renderIndex)
+import Feature.Generation.Links (genLink)
+import Feature.Sharing.SQLite (findByLink, insertNewSecret)
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.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 Prelude
@@ -17,11 +20,17 @@ routes :: PurrApp ()
routes = do
get "/pw/:id" $ do
- reqId <- param "id"
- secretRes <- findByLink reqId
- html $ renderIndex reqId (findToSecret secretRes)
+ reqId <- param "id"
+ res <- findByLink reqId
+ html $ renderIndex reqId (secret <$> res)
post "/pw" $ do
- reqId <- param "userLink"
- secretRes <- findByLink reqId
- html $ renderPw reqId (findToSecret secretRes)
+ reqId <- param "userLink"
+ res <- findByLink reqId
+ 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)
diff --git a/src/Feature/Sharing/SQLite.hs b/src/Feature/Sharing/SQLite.hs
@@ -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
diff --git a/src/Feature/Sharing/Templates.hs b/src/Feature/Sharing/Templates.hs
@@ -3,6 +3,7 @@
module Feature.Sharing.Templates ( renderPw ) where
+import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import Text.Blaze.Html.Renderer.Text (renderHtml)
@@ -11,5 +12,5 @@ import Text.Hamlet (shamletFile)
import Prelude
-renderPw :: String -> Maybe String -> LT.Text
+renderPw :: String -> Maybe T.Text -> LT.Text
renderPw link password = renderHtml ( $(shamletFile "./views/pw.hamlet") )
diff --git a/src/Feature/Sharing/Types.hs b/src/Feature/Sharing/Types.hs
@@ -1,28 +1,19 @@
module Feature.Sharing.Types where
-import Data.Aeson
import Data.Map.Strict (Map)
import Data.Typeable (Typeable)
import GHC.Generics
-data SecretEntry = SecretEntry
- { _id :: Maybe String
- , _rev :: Maybe String
- , creationTime :: String
- , link :: String
- , secret :: String
- } deriving (Generic, Show, Typeable)
+import Database.SQLite.Simple
+import Database.SQLite.Simple.FromRow
-data FindResults = FindResults
- { bookmark :: String
- , docs :: [SecretEntry]
- , warning :: Maybe String
- } deriving (Generic, Show, Typeable)
+import qualified Data.Text as T
-instance ToJSON SecretEntry where
- toEncoding = genericToEncoding defaultOptions
-instance ToJSON FindResults where
- toEncoding = genericToEncoding defaultOptions
+data SecretEntry = SecretEntry
+ { link :: T.Text
+ , secret :: T.Text
+ , date :: Integer
+ } deriving (Show, Generic)
-instance FromJSON SecretEntry
-instance FromJSON FindResults
+instance FromRow SecretEntry where
+instance ToRow SecretEntry where
diff --git a/src/Lib.hs b/src/Lib.hs
@@ -2,10 +2,10 @@ module Lib ( main ) where
import qualified Core.Configuration as Configuration
import qualified Core.HTTP as HTTP
-import qualified Core.Couch as DB
+import qualified Core.SQLite as DB
import Core.Types
-import Control.Monad.Reader (liftIO, runReaderT)
+import Control.Monad.Reader (lift, liftIO, runReaderT)
import GHC.Natural (popCountNatural)
import Prelude hiding (id)
import Web.Scotty.Trans (scottyT)
@@ -13,6 +13,7 @@ import Web.Scotty.Trans (scottyT)
main :: IO ()
main = do
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)
diff --git a/views/index.hamlet b/views/index.hamlet
@@ -30,15 +30,15 @@ $doctype 5
<div #shareNew .shareNew>
<p>
<input .mainInput
- name="newPw"
+ name="newSec"
type="text"
placeholder="Enter a Secret to Share"
/>
<button .mainButton
- hx-post="/newpw"
+ hx-post="/new"
hx-target="#requestedPw"
hx-swap="outerHTML"
- hx-include="[name='newPw']"
+ hx-include="[name='newSec']"
/>
Share Secret
