diff --git a/.gitignore b/.gitignore index c435316..73533db 100644 --- a/.gitignore +++ b/.gitignore @@ -2,6 +2,6 @@ data/ bin/ /config.dhall /Dockerfile -docker-stack.yml +/docker-stack.yml .stack-work/ *~ diff --git a/Purr.cabal b/Purr.cabal index c1675b4..a672501 100644 --- a/Purr.cabal +++ b/Purr.cabal @@ -22,6 +22,7 @@ library Core.Configuration Core.HTTP Core.Mongo + Core.Templates Core.Types Feature.Handlers Lib @@ -30,17 +31,18 @@ library hs-source-dirs: src default-extensions: - OverloadedStrings - GeneralizedNewtypeDeriving - DeriveGeneric ConstraintKinds + DeriveGeneric FlexibleContexts FlexibleInstances + GeneralizedNewtypeDeriving + OverloadedStrings ScopedTypeVariables build-depends: AesonBson ==0.4.1 , aeson >=2.0.0.0 , base >=4.7 + , blaze-html >=0.9.1.0 , bson >=0.3 , dhall >=1.40 && <1.41.2 , http-types >=0.12.3 @@ -48,6 +50,7 @@ library , mongoDB >=2.7.1.1 , mtl >=2.2.2 , scotty ==0.12 + , shakespeare >=2.0.20 , text >=1.2 , time >=1.9 , wai-extra >=3.1.12.1 @@ -60,12 +63,12 @@ executable Purr-exe hs-source-dirs: app default-extensions: - OverloadedStrings - GeneralizedNewtypeDeriving - DeriveGeneric ConstraintKinds + DeriveGeneric FlexibleContexts FlexibleInstances + GeneralizedNewtypeDeriving + OverloadedStrings ScopedTypeVariables ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: @@ -73,6 +76,7 @@ executable Purr-exe , Purr , aeson >=2.0.0.0 , base >=4.7 + , blaze-html >=0.9.1.0 , bson >=0.3 , dhall >=1.40 && <1.41.2 , http-types >=0.12.3 @@ -80,6 +84,7 @@ executable Purr-exe , mongoDB >=2.7.1.1 , mtl >=2.2.2 , scotty ==0.12 + , shakespeare >=2.0.20 , text >=1.2 , time >=1.9 , wai-extra >=3.1.12.1 @@ -93,12 +98,12 @@ test-suite Purr-test hs-source-dirs: test default-extensions: - OverloadedStrings - GeneralizedNewtypeDeriving - DeriveGeneric ConstraintKinds + DeriveGeneric FlexibleContexts FlexibleInstances + GeneralizedNewtypeDeriving + OverloadedStrings ScopedTypeVariables ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: @@ -106,6 +111,7 @@ test-suite Purr-test , Purr , aeson >=2.0.0.0 , base >=4.7 + , blaze-html >=0.9.1.0 , bson >=0.3 , dhall >=1.40 && <1.41.2 , http-types >=0.12.3 @@ -113,6 +119,7 @@ test-suite Purr-test , mongoDB >=2.7.1.1 , mtl >=2.2.2 , scotty ==0.12 + , shakespeare >=2.0.20 , text >=1.2 , time >=1.9 , wai-extra >=3.1.12.1 diff --git a/README.md b/README.md index 3d259ab..7d59f11 100644 --- a/README.md +++ b/README.md @@ -13,7 +13,7 @@ Purr is a work-in-progress web application offering customizable password genera 3. [MongoDB](https://github.com/mongodb/mongo) database. ## Why should I trust you with my passwords? -You shouldn't! This is free and open-source software 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 soon. ## Development & Support Please send me an [email](mailto:james@eversole.co) or join the [Support Chat](openpgp4fpr://FEB27223219E8DB3203225350462EA0901FE08F7#a=james%40eversole.co&g=Purr%20Support&x=RbVs8iQCVnf&i=-FuzUDK_RM1&s=KgeGtFFJtkq) in [DeltaChat](https://delta.chat)! diff --git a/examples/docker-stack.yml b/examples/docker-stack.yml new file mode 100644 index 0000000..a0ca67a --- /dev/null +++ b/examples/docker-stack.yml @@ -0,0 +1,44 @@ +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. + +services: + mongodb: + image: mongo:4.4.6 + ports: + - 27017:27017 + volumes: + - ./data:/opt/purr/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 + + purr: + image: purr + ports: + - 3000:3000 + networks: + - webnet + depends_on: + - mongodb + +networks: + webnet: diff --git a/package.yaml b/package.yaml index 3d0646e..e409425 100644 --- a/package.yaml +++ b/package.yaml @@ -10,12 +10,12 @@ extra-source-files: - ChangeLog.md default-extensions: -- OverloadedStrings -- GeneralizedNewtypeDeriving -- DeriveGeneric - ConstraintKinds +- DeriveGeneric - FlexibleContexts - FlexibleInstances +- GeneralizedNewtypeDeriving +- OverloadedStrings - ScopedTypeVariables # Metadata used when publishing your package @@ -30,14 +30,16 @@ description: https://git.eversole.co/James/Purr dependencies: - aeson >= 2.0.0.0 - AesonBson == 0.4.1 -- bson >= 0.3 - base >= 4.7 +- blaze-html >= 0.9.1.0 +- bson >= 0.3 - 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 - scotty == 0.12 +- shakespeare >= 2.0.20 - time >= 1.9 - text >= 1.2 - wai-extra >= 3.1.12.1 diff --git a/src/Core/HTTP.hs b/src/Core/HTTP.hs index c9be776..4ce4c40 100644 --- a/src/Core/HTTP.hs +++ b/src/Core/HTTP.hs @@ -2,7 +2,7 @@ module Core.HTTP ( app ) where import Core.Types -import Feature.Handlers as RES +import Feature.Handlers as HD import Network.Wai.Middleware.RequestLogger (logStdoutDev) import Web.Scotty.Trans @@ -11,4 +11,4 @@ app :: PurrApp () app = do middleware logStdoutDev - get "/" RES.root + get "/:id" HD.pwLookup diff --git a/src/Core/Mongo.hs b/src/Core/Mongo.hs index 46f1d45..fa97b6f 100644 --- a/src/Core/Mongo.hs +++ b/src/Core/Mongo.hs @@ -1,20 +1,47 @@ -module Core.Mongo ( mongoSetup, tempGetDocs ) where + module Core.Mongo ( mongoSetup, getAllDocs, findByLink ) where import Core.Types -import Control.Monad.Reader (MonadIO) +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 + +-- 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)) + 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) - -tempGetDocs :: MonadIO m => AppConfig -> m [Document] -tempGetDocs appConfig = access (mongoPipe db) (mongoAccessMode db) (mongoDatabase db) $ find (select [] (collection conf)) >>= rest - where - db = dbconn appConfig - conf = res appConfig diff --git a/src/Core/Templates.hs b/src/Core/Templates.hs new file mode 100644 index 0000000..8b3f916 --- /dev/null +++ b/src/Core/Templates.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} + +module Core.Templates ( renderIndex ) where + +import Database.MongoDB (Document) +import Text.Blaze.Html.Renderer.String (renderHtml) +import Text.Blaze.Html +import Text.Hamlet (shamletFile) + +import Prelude + +renderIndex :: String -> Maybe String -> String +renderIndex link password = renderHtml ( $(shamletFile "./views/index.hamlet") ) diff --git a/src/Feature/Handlers.hs b/src/Feature/Handlers.hs index 4a33ddf..8c77ef4 100644 --- a/src/Feature/Handlers.hs +++ b/src/Feature/Handlers.hs @@ -1,18 +1,23 @@ -module Feature.Handlers ( root ) where +module Feature.Handlers ( pwLookup ) where import Core.Types +import Core.Templates import qualified Core.Mongo as DB import Control.Monad.Reader (ask, lift) import Data.AesonBson (aesonify) -import Data.Bson (Document, Field (..), Value (Array, Doc)) +import Data.Bson (Document, Field (..), Value (Array, Doc), lookup) import qualified Data.Text as T import qualified Data.Text.Lazy as LT -import Web.Scotty.Trans (json) -import Prelude hiding (id) +import Web.Scotty.Trans (html, param) +import Prelude hiding (id, lookup) -root :: PurrAction () -root = do - config <- lift $ ask - docs <- DB.tempGetDocs config - json $ aesonify ["allDocs" := Array (map Doc docs)] +pwLookup :: PurrAction () +pwLookup = do + id <- param "id" + doc <- DB.findByLink id + html $ LT.pack $ renderIndex id (pwLook doc) + where + pwLook :: Maybe Document -> Maybe String + pwLook (Just x) = (lookup "password" x) :: Maybe String + pwLook _ = Nothing diff --git a/views/index.hamlet b/views/index.hamlet new file mode 100644 index 0000000..865d18e --- /dev/null +++ b/views/index.hamlet @@ -0,0 +1,8 @@ + + + Purr + <body> + $maybe pw <- password + <p>Here's the password for #{link}: #{pw} + $nothing + <p>No password available at https://purr.eversole.co/#{link}