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

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

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

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