commit d15b40a33900533c35d65334db11678246d4458a
parent f7a61dcddc26f441713133aa1f470315c36e59ac
Author: James Eversole <james@eversole.co>
Date: Sat, 2 Jul 2022 13:23:53 -0500
Added Shakespeare templating and setup basic Maybe-bound lookup for conditional rendering of the page or an appropriate notice that the password doesn't exist.
Diffstat:
10 files changed, 144 insertions(+), 37 deletions(-)
diff --git 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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -0,0 +1,8 @@
+<html>
+ <head>
+ <title>Purr
+ <body>
+ $maybe pw <- password
+ <p>Here's the password for #{link}: #{pw}
+ $nothing
+ <p>No password available at https://purr.eversole.co/#{link}
