diff --git a/Purr.cabal b/Purr.cabal index 8398a8e..e584fa4 100644 --- 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 index 399464e..850d125 100644 --- 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 index dbbba7b..ffdb529 100644 --- 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 index a0ca67a..301b513 100644 --- 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 index e409425..2007235 100644 --- 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 new file mode 100644 index 0000000..8e46b76 --- /dev/null +++ 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 deleted file mode 100644 index 7fe3901..0000000 --- a/src/Core/Mongo.hs +++ /dev/null @@ -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 index 993468c..3547d46 100644 --- 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 index 7704ee3..d8dea6b 100644 --- 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 new file mode 100644 index 0000000..0bd1d79 --- /dev/null +++ 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 index 6456795..6099497 100644 --- 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 deleted file mode 100644 index c4b66fc..0000000 --- a/src/Feature/Sharing/Mongo.hs +++ /dev/null @@ -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 index d1fd4b8..6e60c8d 100644 --- 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 new file mode 100644 index 0000000..b1be568 --- /dev/null +++ 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 index a4412a4..245aa0c 100644 --- 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)