Squashed commit of the following:

commit 86ee3c4d262916bec531ad5616273b391cdffeb3
Author: James Eversole <james@eversole.co>
Date:   Tue Jul 5 20:09:22 2022 -0500

    Refactored findByLink for modularity, started prototyping document creation

commit 65b68df295069edb57adcdc16a3300c9d762dc2f
Author: James Eversole <james@eversole.co>
Date:   Tue Jul 5 18:45:25 2022 -0500

    Feature parity with MongoDB implementation in main; need to refactor Feature.Sharing.Couch.findByLink into multiple functions so that more information regarding retrieved documents can be used compositionally to DRY before merging into main

commit e10cc4de8acd45488679f0587732f02fee950c77
Author: James Eversole <james@eversole.co>
Date:   Mon Jul 4 20:53:55 2022 -0500

    Better configuration file keys

commit d683a51cac4ad891856f7782aa6221402988fea4
Author: James Eversole <james@eversole.co>
Date:   Mon Jul 4 20:38:40 2022 -0500

    Added beginnings of CouchDB logic while removing all Mongo references and dependencies. Updated configuration file and related data types. Added a MonadHttp instance for PurrAction to enable requests in their monadic context. Will merge into main once feature parity on the Sharing Feature is reached

Purr.cabal

@@ -20,13 +20,14 @@ extra-source-files:
 library
   exposed-modules:
       Core.Configuration
+      Core.Couch
       Core.HTTP
-      Core.Mongo
       Core.Templates
       Core.Types
+      Feature.Sharing.Couch
       Feature.Sharing.HTTP
-      Feature.Sharing.Mongo
       Feature.Sharing.Templates
+      Feature.Sharing.Types
       Lib
   other-modules:
       Paths_Purr
@@ -41,16 +42,16 @@ library
       OverloadedStrings
       ScopedTypeVariables
   build-depends:
-      AesonBson ==0.4.1
+      aeson >=2.0.0.0
-    , aeson >=2.0.0.0
     , base >=4.7
     , blaze-html >=0.9.1.0
-    , bson >=0.3
+    , bytestring
+    , containers
     , dhall >=1.40 && <1.41.2
     , http-types >=0.12.3
     , iso8601-time >=0.1.5
-    , mongoDB >=2.7.1.1
     , mtl >=2.2.2
+    , req >=3.10.0
     , scotty ==0.12
     , shakespeare >=2.0.20
     , text >=1.2
@@ -74,17 +75,17 @@ executable Purr-exe
       ScopedTypeVariables
   ghc-options: -threaded -rtsopts -with-rtsopts=-N
   build-depends:
-      AesonBson ==0.4.1
+      Purr
-    , Purr
     , aeson >=2.0.0.0
     , base >=4.7
     , blaze-html >=0.9.1.0
-    , bson >=0.3
+    , bytestring
+    , containers
     , dhall >=1.40 && <1.41.2
     , http-types >=0.12.3
     , iso8601-time >=0.1.5
-    , mongoDB >=2.7.1.1
     , mtl >=2.2.2
+    , req >=3.10.0
     , scotty ==0.12
     , shakespeare >=2.0.20
     , text >=1.2
@@ -109,17 +110,17 @@ test-suite Purr-test
       ScopedTypeVariables
   ghc-options: -threaded -rtsopts -with-rtsopts=-N
   build-depends:
-      AesonBson ==0.4.1
+      Purr
-    , Purr
     , aeson >=2.0.0.0
     , base >=4.7
     , blaze-html >=0.9.1.0
-    , bson >=0.3
+    , bytestring
+    , containers
     , dhall >=1.40 && <1.41.2
     , http-types >=0.12.3
     , iso8601-time >=0.1.5
-    , mongoDB >=2.7.1.1
     , mtl >=2.2.2
+    , req >=3.10.0
     , scotty ==0.12
     , shakespeare >=2.0.20
     , text >=1.2

README.md

@@ -8,12 +8,12 @@ Purr is a work-in-progress web application offering customizable password genera
 3. Being really cute compared to the competition.
 
 ## Why should I trust you with my secrets?
-You shouldn't! This is [free and open-source software](https://git.eversole.co/James/Purr/src/branch/main/LICENSE) which you can run on your own hardware. Instructions for deployment are coming soon.
+You shouldn't! This is [free and open-source software](https://git.eversole.co/James/Purr/src/branch/main/LICENSE) which you can run on your own hardware. Instructions for deployment are coming!
 
 ## 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. [MongoDB](https://github.com/mongodb/mongo) database.
+3. [CouchDB](https://gitbox.apache.org/repos/asf?p=couchdb.git) database.
 
 ## Project Goals
 1. Provide a minimal and clean interface for generating and sharing passwords.

examples/config.dhall

@@ -1,10 +1,18 @@
 -- /config.dhall
-{ hostname = "localhost"
+{- 
-, port = +3001
+  Default Dhall Configuration for Purr.
-, environment = "development"
+  You will need to change all instances of "REPLACEME" with the 
-, adminDB = "admin"
+  appropriate details. Additionally, you may want to change the
-, dataDB = "data"
+  applicationPort from 3000 and the couchPort.
-, collection = "store"
+-}
-, mongoUsername = "root"
+
-, mongoPassword = "REPLACEME"
+{ environment     = "production"
+, applicationHost = "REPLACEME"
+, applicationPort = +3000
+, couchHost       = "REPLACEME"
+, couchPort       = +5984
+, couchUsername   = "REPLACEME"
+, couchPassword   = "REPLACEME"
+, adminDB         = "REPLACEME"
+, dataDB          = "REPLACEME"
 }

examples/docker-stack.yml

@@ -2,43 +2,29 @@ version: '3.1'
 
 # Default Docker Stack/Compose configuration for Purr.
 # You will need to change all instances of "REPLACEME" with the appropriate details.
-# Additionally, you may want to update the host port definitions for each service and
+# Additionally, you may want to update the host port definitions for each service.
-# remove the Mongo Express service entirely for production.
 
 services:
-  mongodb:
+  couchdb:
-    image: mongo:4.4.6
+    image: couchdb:3.2.2
     ports:
-      - 27017:27017
+      - 5984:5984
     volumes:
-      - ./data:/opt/purr/data
+      - ./data:/opt/couchdb/data
     networks:
       - webnet
     environment:
-      MONGO_INITDB_ROOT_USERNAME: REPLACEME
+      COUCHDB_USER: REPLACEME
-      MONGO_INITDB_ROOT_PASSWORD: REPLACEME
+      COUCHDB_PASSWORD: REPLACEME
-
-  mexpress:
-    image: mongo-express
-    ports:
-      - 8081:8081
-    environment:
-      ME_CONFIG_MONGODB_ADMINUSERNAME: REPLACEME
-      ME_CONFIG_MONGODB_ADMINPASSWORD: REPLACEME
-      ME_CONFIG_MONGODB_SERVER: mongodb
-    networks:
-      - webnet
-    depends_on:
-      - mongodb
 
   purr: 
     image: purr
     ports: 
-      - 3000:3000
+      - 5195:3000
     networks:
       - webnet
     depends_on: 
-      - mongodb
+      - couchdb
 
 networks:
   webnet:

package.yaml

@@ -29,15 +29,15 @@ description:         https://git.eversole.co/James/Purr
 
 dependencies:
 - aeson >= 2.0.0.0
-- AesonBson == 0.4.1
 - base >= 4.7 
 - blaze-html >= 0.9.1.0
-- bson >= 0.3
+- bytestring
+- containers
 - dhall >= 1.40 && < 1.41.2
 - http-types >= 0.12.3
 - iso8601-time >= 0.1.5 
-- mongoDB >= 2.7.1.1 
 - mtl >= 2.2.2 
+- req >= 3.10.0
 - scotty == 0.12
 - shakespeare >= 2.0.20
 - time >= 1.9

src/Core/Couch.hs

@@ -0,0 +1,79 @@
+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/Mongo.hs

@@ -1,21 +0,0 @@
-module Core.Mongo ( mongoSetup ) where
-
-import Core.Types
-
-import Control.Monad.Reader (MonadIO, lift, ask)
-import Data.Maybe
-import Data.Text            (Text)
-import Database.MongoDB
-import Prelude
-
--- Authenticates to Mongo and returns the MongoContext for the dataDB
-mongoSetup :: DhallConfig -> IO MongoContext
-mongoSetup conf = do
-  mongoCon     <- connect $ host (hostname conf)
-  let adminCon  = MongoContext mongoCon master (adminDB conf)
-  access 
-    (mongoPipe       adminCon) 
-    (mongoAccessMode adminCon) 
-    (mongoDatabase   adminCon) 
-    (auth (mongoUsername conf) (mongoPassword conf))
-  return $ MongoContext mongoCon master (dataDB conf)

src/Core/Templates.hs

@@ -4,7 +4,6 @@
 module Core.Templates ( renderIndex, renderStyle ) where
 
 import Data.Text.Lazy                (Text)
-import Database.MongoDB              (Document)
 import Text.Blaze.Html.Renderer.Text (renderHtml)
 import Text.Blaze.Html
 import Text.Cassius                  (cassiusFile, renderCss)

src/Core/Types.hs

@@ -4,8 +4,8 @@ import qualified Data.Text.Lazy as LT
 
 import Control.Monad.Reader (MonadIO, MonadReader, ReaderT)
 import Data.Text
-import Database.MongoDB     (MongoContext)
 import GHC.Generics         (Generic)
+import Network.HTTP.Req     (HttpException, MonadHttp, handleHttpException)
 import Numeric.Natural      (Natural)
 import Web.Scotty.Trans     (ScottyT, ActionT)
 
@@ -13,21 +13,20 @@ type PurrApp    a = ScottyT LT.Text ConfigM a
 type PurrAction a = ActionT LT.Text ConfigM a
 
 newtype ConfigM a = ConfigM
-  { runConfigM :: ReaderT AppConfig IO a
+  { runConfigM :: ReaderT DhallConfig IO a
-  } deriving (Applicative, Functor, Monad, MonadIO, MonadReader AppConfig)
+  } deriving (Applicative, Functor, Monad, MonadIO, MonadReader DhallConfig)
 
-data AppConfig = AppConfig
+instance MonadHttp (ActionT LT.Text ConfigM) where
-  { res    :: DhallConfig
+  handleHttpException = error . show
-  , dbconn :: MongoContext
-  }
 
 data DhallConfig = DhallConfig
-  { hostname      :: String
+  { environment     :: String
-  , port          :: Int
+  , applicationHost :: String
-  , environment   :: Text
+  , applicationPort :: Int
-  , adminDB       :: Text
+  , couchHost       :: String
-  , dataDB        :: Text
+  , couchPort       :: Int
-  , collection    :: Text
+  , couchUsername   :: String
-  , mongoUsername :: Text
+  , couchPassword   :: String
-  , mongoPassword :: Text
+  , adminDB         :: String
+  , dataDB          :: String
   } deriving (Generic, Show)

src/Feature/Sharing/Couch.hs

@@ -0,0 +1,78 @@
+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,31 +3,25 @@ module Feature.Sharing.HTTP ( routes ) where
 import Core.Types
 import Core.Templates (renderIndex)
 
-import           Feature.Sharing.Templates (renderPw)
+import Feature.Sharing.Templates (renderPw)
-import qualified Feature.Sharing.Mongo     as DB
+import Feature.Sharing.Couch     (findByLink, findToSecret)
 
 import qualified Data.Text      as T
 import qualified Data.Text.Lazy as LT
 
 import Control.Monad.Reader (ask, lift)
-import Data.AesonBson       (aesonify)
-import Data.Bson            (Document, Field (..), Value (..), lookup)
 import Web.Scotty.Trans 
-import Prelude              hiding (lookup)
+import Prelude 
 
 routes :: PurrApp ()
 routes = do 
 
   get "/pw/:id" $ do
-    reqId  <- param "id"
+    reqId     <- param "id"
-    doc    <- DB.findByLink reqId
+    secretRes <- findByLink reqId
-    html    $ renderIndex reqId (pwLookup doc)
+    html       $ renderIndex reqId (findToSecret secretRes)
 
   post "/pw" $ do
-    reqId  <- param "userLink"
+    reqId     <- param "userLink"
-    doc    <- DB.findByLink reqId
+    secretRes <- findByLink reqId
-    html    $ renderPw reqId (pwLookup doc)
+    html       $ renderPw reqId (findToSecret secretRes)
-
-pwLookup :: Maybe Document -> Maybe String
-pwLookup (Just x) = lookup "password" x
-pwLookup _        = Nothing

src/Feature/Sharing/Mongo.hs

@@ -1,35 +0,0 @@
-module Feature.Sharing.Mongo ( getAllDocs, findByLink ) where
-
-import Core.Types
-
-import Control.Monad.Reader (MonadIO, lift, ask)
-import Data.Maybe
-import Data.Text            (Text)
-import Database.MongoDB
-import Prelude
-
-findByLink :: String -> PurrAction (Maybe Document)
-findByLink link = do
-  col      <- confCollection
-  dataConn <- dataAccess
-  dataConn  $ findOne (select ["link" =: link] col)
-
-getAllDocs :: PurrAction [Document]
-getAllDocs = do
-  col      <- confCollection
-  dataConn <- dataAccess
-  dataConn  $ find (select [] col)
-    >>= rest
-
-dataAccess :: MonadIO m => PurrAction (Action m a -> m a)
-dataAccess = do
-  appConfig <- lift ask
-  return     $ access
-    (mongoPipe         $ dbconn appConfig)
-    (mongoAccessMode   $ dbconn appConfig)
-    (mongoDatabase     $ dbconn appConfig)
-
-confCollection :: PurrAction Text
-confCollection = do
-  appConfig <- lift ask
-  return     $ collection $ res appConfig

src/Feature/Sharing/Templates.hs

@@ -5,7 +5,6 @@ module Feature.Sharing.Templates ( renderPw ) where
 
 import qualified Data.Text.Lazy as LT
 
-import Database.MongoDB                (Document)
 import Text.Blaze.Html.Renderer.Text   (renderHtml)
 import Text.Blaze.Html
 import Text.Hamlet                     (shamletFile)

src/Feature/Sharing/Types.hs

@@ -0,0 +1,28 @@
+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)
+
+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

src/Lib.hs

@@ -2,11 +2,10 @@ module Lib ( main ) where
 
 import qualified Core.Configuration as Configuration
 import qualified Core.HTTP          as HTTP
-import qualified Core.Mongo         as DB
+import qualified Core.Couch         as DB
 import           Core.Types
 
 import Control.Monad.Reader (liftIO, runReaderT)
-import Database.MongoDB     (MongoContext)
 import GHC.Natural          (popCountNatural)
 import Prelude              hiding (id)
 import Web.Scotty.Trans     (scottyT)
@@ -14,10 +13,6 @@ import Web.Scotty.Trans     (scottyT)
 main :: IO ()
 main = do
   dhallConf <- liftIO Configuration.main
-  dataDB    <- liftIO $ DB.mongoSetup dhallConf
+  scottyT (applicationPort dhallConf) (flip runApp dhallConf) HTTP.app where
-  let config = AppConfig { res    = dhallConf
+    runApp :: ConfigM a -> DhallConfig -> IO a
-                         , dbconn = dataDB
-                         }
-  scottyT (port dhallConf) (flip runApp config) HTTP.app where
-    runApp :: ConfigM a -> AppConfig -> IO a
     runApp m = runReaderT (runConfigM m)