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.

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

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.

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

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

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

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

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)

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  

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

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

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)

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

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

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
 
+import Database.SQLite.Simple
+import Database.SQLite.Simple.FromRow
+
+import qualified Data.Text as T
+
 data SecretEntry = SecretEntry 
-   { _id          :: Maybe String
-   , _rev         :: Maybe String
-   , creationTime :: String
-   , link         :: String
-   , secret       :: String
-   } deriving (Generic, Show, Typeable)
+ { link   :: T.Text 
+ , secret :: T.Text 
+ , date   :: Integer
+ } deriving (Show, Generic)
 
-data FindResults = FindResults
-  { bookmark :: String
-  , docs     :: [SecretEntry]
-  , warning  :: Maybe String
-  } deriving (Generic, Show, Typeable)
-
-instance ToJSON SecretEntry where
-  toEncoding = genericToEncoding defaultOptions
-instance ToJSON FindResults where
-  toEncoding = genericToEncoding defaultOptions
-
-instance FromJSON SecretEntry
-instance FromJSON FindResults
+instance FromRow SecretEntry where
+instance ToRow SecretEntry where

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)

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