commit 6a0b5b014499af788951b8a3e16b8eb0b0b5b2b9
parent f1b18f3b478d15148b8abb5c7dfb95c9c0d33cad
Author: James Eversole <james@eversole.co>
Date: Tue, 5 Jul 2022 20:11:41 -0500
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
Diffstat:
15 files changed, 256 insertions(+), 146 deletions(-)
diff --git 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
diff --git 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.
diff --git 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"
}
diff --git 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:
diff --git 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
diff --git 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
diff --git 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)
diff --git 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)
diff --git 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)
diff --git 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
diff --git 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)
diff --git 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
diff --git 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)
diff --git 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
diff --git 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)
