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
2022-07-05 20:11:41 -05:00 · 2022-07-05 20:11:41 -05:00 · 6a0b5b0144
commit 6a0b5b0144
parent f1b18f3b47
15 changed files with 256 additions and 146 deletions
--- a/Purr.cabal
+++ b/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
--- a/README.md
+++ b/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.
--- a/examples/config.dhall
+++ b/examples/config.dhall
@ -1,10 +1,18 @@
 -- /config.dhall
-{ hostname = "localhost"
-, port = +3001
-, environment = "development"
-, adminDB = "admin"
-, dataDB = "data"
-, collection = "store"
-, mongoUsername = "root"
-, mongoPassword = "REPLACEME"
+{- 
+  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 and the couchPort.
+-}
+
+{ environment     = "production"
+, applicationHost = "REPLACEME"
+, applicationPort = +3000
+, couchHost       = "REPLACEME"
+, couchPort       = +5984
+, couchUsername   = "REPLACEME"
+, couchPassword   = "REPLACEME"
+, adminDB         = "REPLACEME"
+, dataDB          = "REPLACEME"
 }
--- a/examples/docker-stack.yml
+++ b/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
-# remove the Mongo Express service entirely for production.
+# Additionally, you may want to update the host port definitions for each service.

 services:
-  mongodb:
-    image: mongo:4.4.6
+  couchdb:
+    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
-      MONGO_INITDB_ROOT_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
+      COUCHDB_USER: REPLACEME
+      COUCHDB_PASSWORD: REPLACEME

  purr: 
    image: purr
    ports: 
-      - 3000:3000
+      - 5195:3000
    networks:
      - webnet
    depends_on: 
-      - mongodb
+      - couchdb

 networks:
  webnet:
--- a/package.yaml
+++ b/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
--- a/src/Core/Couch.hs
+++ b/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
--- a/src/Core/Mongo.hs
+++ b/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)
--- a/src/Core/Templates.hs
+++ b/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)
--- a/src/Core/Types.hs
+++ b/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
-  } deriving (Applicative, Functor, Monad, MonadIO, MonadReader AppConfig)
+  { runConfigM :: ReaderT DhallConfig IO a
+  } deriving (Applicative, Functor, Monad, MonadIO, MonadReader DhallConfig)

-data AppConfig = AppConfig
-  { res    :: DhallConfig
-  , dbconn :: MongoContext
-  }
+instance MonadHttp (ActionT LT.Text ConfigM) where
+  handleHttpException = error . show

 data DhallConfig = DhallConfig
-  { hostname      :: String
-  , port          :: Int
-  , environment   :: Text
-  , adminDB       :: Text
-  , dataDB        :: Text
-  , collection    :: Text
-  , mongoUsername :: Text
-  , mongoPassword :: Text
+  { environment     :: String
+  , applicationHost :: String
+  , applicationPort :: Int
+  , couchHost       :: String
+  , couchPort       :: Int
+  , couchUsername   :: String
+  , couchPassword   :: String
+  , adminDB         :: String
+  , dataDB          :: String
  } deriving (Generic, Show)
--- a/src/Feature/Sharing/Couch.hs
+++ b/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
--- a/src/Feature/Sharing/HTTP.hs
+++ b/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 qualified Feature.Sharing.Mongo     as DB
+import Feature.Sharing.Templates (renderPw)
+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"
-    doc    <- DB.findByLink reqId
-    html    $ renderIndex reqId (pwLookup doc)
+    reqId     <- param "id"
+    secretRes <- findByLink reqId
+    html       $ renderIndex reqId (findToSecret secretRes)

  post "/pw" $ do
-    reqId  <- param "userLink"
-    doc    <- DB.findByLink reqId
-    html    $ renderPw reqId (pwLookup doc)
-
-pwLookup :: Maybe Document -> Maybe String
-pwLookup (Just x) = lookup "password" x
-pwLookup _        = Nothing
+    reqId     <- param "userLink"
+    secretRes <- findByLink reqId
+    html       $ renderPw reqId (findToSecret secretRes)
--- a/src/Feature/Sharing/Mongo.hs
+++ b/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
--- a/src/Feature/Sharing/Templates.hs
+++ b/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)
--- a/src/Feature/Sharing/Types.hs
+++ b/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
--- a/src/Lib.hs
+++ b/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
-  let config = AppConfig { res    = dhallConf
-                         , dbconn = dataDB
-                         }
-  scottyT (port dhallConf) (flip runApp config) HTTP.app where
-    runApp :: ConfigM a -> AppConfig -> IO a
+  scottyT (applicationPort dhallConf) (flip runApp dhallConf) HTTP.app where
+    runApp :: ConfigM a -> DhallConfig -> IO a
    runApp m = runReaderT (runConfigM m)