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.

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

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