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.

.gitignore

@@ -2,6 +2,6 @@ data/
 bin/
 /config.dhall
 /Dockerfile
-docker-stack.yml
+/docker-stack.yml
 .stack-work/
 *~

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

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

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:

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

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

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)
+  mongoCon     <- connect $ host (hostname conf)
-  let adminCon = MongoContext mongoCon master (adminDB conf)
+  let adminCon  = MongoContext mongoCon master (adminDB conf)
-  access (mongoPipe adminCon) (mongoAccessMode adminCon) (mongoDatabase adminCon) (auth (mongoUsername conf) (mongoPassword 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

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

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 Web.Scotty.Trans (html, param)
-import Prelude hiding (id)
+import Prelude hiding (id, lookup)
 
-root :: PurrAction ()
+pwLookup :: PurrAction ()
-root = do 
+pwLookup = do 
-  config <- lift $ ask
+  id  <- param "id"
-  docs   <- DB.tempGetDocs config
+  doc <- DB.findByLink id
-  json $ aesonify ["allDocs" := Array (map Doc docs)]
+  html $ LT.pack $ renderIndex id (pwLook doc)
+    where
+      pwLook :: Maybe Document -> Maybe String
+      pwLook (Just x) = (lookup "password" x) :: Maybe String
+      pwLook _ = Nothing

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}