commit f088ff3690c8959f2b69fa726c8fe88d2171589a
parent d15b40a33900533c35d65334db11678246d4458a
Author: James Eversole <james@eversole.co>
Date: Sat, 2 Jul 2022 18:37:30 -0500
Beginnings of HTMX frontend interaction, able to request particular PWs by link names and patch the DOM appropriately
Diffstat:
12 files changed, 120 insertions(+), 65 deletions(-)
diff --git a/Purr.cabal b/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
diff --git a/src/Core/HTTP.hs b/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
diff --git a/src/Core/Mongo.hs b/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
diff --git a/src/Core/Templates.hs b/src/Core/Templates.hs
@@ -3,12 +3,14 @@
module Core.Templates ( renderIndex ) where
-import Database.MongoDB (Document)
-import Text.Blaze.Html.Renderer.String (renderHtml)
+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 Text.Hamlet (shamletFile)
import Prelude
-renderIndex :: String -> Maybe String -> String
-renderIndex link password = renderHtml ( $(shamletFile "./views/index.hamlet") )
+renderIndex :: LT.Text
+renderIndex = renderHtml ( $(shamletFile "./views/index.hamlet") )
diff --git a/src/Core/Types.hs b/src/Core/Types.hs
@@ -31,4 +31,3 @@ data DhallConfig = DhallConfig
, mongoUsername :: Text
, mongoPassword :: Text
} deriving (Generic, Show)
-
diff --git a/src/Feature/Handlers.hs b/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
diff --git a/src/Feature/Sharing/HTTP.hs b/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
diff --git a/src/Feature/Sharing/Mongo.hs b/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
diff --git a/src/Feature/Sharing/Templates.hs b/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") )
diff --git a/src/Lib.hs b/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
diff --git a/views/index.hamlet b/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
- <p>Here's the password for #{link}: #{pw}
- $nothing
- <p>No password available at https://purr.eversole.co/#{link}
+ <h1>Welcome to Purr!
+ <p #requestedPw>No password currently requested.
+ <p>Ask for the <input name="userLink" type="text"/> password
+ <button hx-post="/pw"
+ hx-target="#requestedPw"
+ hx-swap="outerHTML"
+ hx-include="[name='userLink']"
+ />
+ Get Password!
diff --git a/views/pw.hamlet b/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}
