Beginnings of HTMX frontend interaction, able to request particular PWs by link names and patch the DOM appropriately

Purr.cabal

@@ -24,7 +24,9 @@ library
       Core.Mongo
       Core.Templates
       Core.Types
-      Feature.Handlers
+      Feature.Sharing.HTTP
+      Feature.Sharing.Mongo
+      Feature.Sharing.Templates
       Lib
   other-modules:
       Paths_Purr

src/Core/HTTP.hs

@@ -2,13 +2,20 @@ module Core.HTTP ( app ) where
 
 import Core.Types
 
-import Feature.Handlers as HD
+import Core.Templates       (renderIndex)
+import Feature.Sharing.HTTP as Sharing
 
 import Network.Wai.Middleware.RequestLogger (logStdoutDev)
 import Web.Scotty.Trans 
 
 app :: PurrApp ()
 app = do
+  -- Middleware definition
   middleware logStdoutDev
 
-  get "/:id" HD.pwLookup
+  -- Core Routes
+  get "/" $ do
+    html $ renderIndex
+
+  -- Feature Routes
+  Sharing.routes

src/Core/Mongo.hs

@@ -1,39 +1,13 @@
- module Core.Mongo ( mongoSetup, getAllDocs, findByLink ) where
+module Core.Mongo ( mongoSetup ) where
 
 import Core.Types
 
 import Control.Monad.Reader (MonadIO, lift, ask)
 import Data.Maybe
-import Data.Text (Text)
+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

src/Core/Templates.hs

@@ -3,12 +3,14 @@
 
 module Core.Templates ( renderIndex ) where
 
-import Database.MongoDB (Document)
+import qualified Data.Text.Lazy                as LT
-import Text.Blaze.Html.Renderer.String (renderHtml)
+
+import Database.MongoDB              (Document)
+import Text.Blaze.Html.Renderer.Text (renderHtml)
 import Text.Blaze.Html
-import Text.Hamlet                     (shamletFile)
+import Text.Hamlet                   (shamletFile)
 
 import Prelude 
 
-renderIndex :: String -> Maybe String -> String
+renderIndex :: LT.Text
-renderIndex link password = renderHtml ( $(shamletFile "./views/index.hamlet") )
+renderIndex = renderHtml ( $(shamletFile "./views/index.hamlet") )

src/Core/Types.hs

@@ -31,4 +31,3 @@ data DhallConfig = DhallConfig
   , mongoUsername :: Text
   , mongoPassword :: Text
   } deriving (Generic, Show)
-

src/Feature/Handlers.hs

@@ -1,23 +0,0 @@
-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), lookup)
-import qualified Data.Text as T
-import qualified Data.Text.Lazy as LT
-import Web.Scotty.Trans (html, param)
-import Prelude hiding (id, lookup)
-
-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

src/Feature/Sharing/HTTP.hs

@@ -0,0 +1,32 @@
+module Feature.Sharing.HTTP ( routes ) where
+
+import           Core.Types
+
+import           Feature.Sharing.Templates
+import qualified Feature.Sharing.Mongo as DB
+
+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 (id, lookup)
+
+routes :: PurrApp ()
+routes = do 
+
+  get "/pw/:id" $ do
+    id  <- param "id"
+    doc <- DB.findByLink id
+    html $ renderPw id (pwLookup doc)
+
+  post "/pw" $ do
+    id  <- param "userLink"
+    doc <- DB.findByLink id
+    html $ renderPw id (pwLookup doc)
+
+pwLookup :: Maybe Document -> Maybe String
+pwLookup (Just x) = (lookup "password" x)
+pwLookup _ = Nothing

src/Feature/Sharing/Mongo.hs

@@ -0,0 +1,35 @@
+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

src/Feature/Sharing/Templates.hs

@@ -0,0 +1,16 @@
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+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)
+
+import Prelude 
+
+renderPw :: String -> Maybe String -> LT.Text
+renderPw link password = renderHtml ( $(shamletFile "./views/pw.hamlet") )

src/Lib.hs

@@ -1,6 +1,6 @@
 module Lib ( main ) where
 
-import Core.Types
+import           Core.Types
 import qualified Core.Configuration as Configuration
 import qualified Core.HTTP          as HTTP
 import qualified Core.Mongo         as DB

views/index.hamlet

@@ -1,8 +1,14 @@
 <html>
   <head>
     <title>Purr
+    <script src="https://unpkg.com/htmx.org@1.7.0" integrity="sha384-EzBXYPt0/T6gxNp0nuPtLkmRpmDBbjg6WmCUZRLXBBwYYmwAUxzlSGej0ARHX0Bo" crossorigin="anonymous">
   <body>
-    $maybe pw <- password
+    <h1>Welcome to Purr!
-      <p>Here's the password for #{link}: #{pw}
+    <p #requestedPw>No password currently requested.
-    $nothing
+    <p>Ask for the <input name="userLink" type="text"/> password
-      <p>No password available at https://purr.eversole.co/#{link}
+    <button hx-post="/pw" 
+      hx-target="#requestedPw" 
+      hx-swap="outerHTML" 
+      hx-include="[name='userLink']"
+    />
+      Get Password!

views/pw.hamlet

@@ -0,0 +1,5 @@
+  <div #requestedPw>
+    $maybe pw <- password
+      <p>Here's the password for #{link}: #{pw}
+    $nothing
+      <p>No password available at https://purr.eversole.co/#{link}