From f088ff3690c8959f2b69fa726c8fe88d2171589a Mon Sep 17 00:00:00 2001 From: James Eversole Date: Sat, 2 Jul 2022 18:37:30 -0500 Subject: [PATCH] Beginnings of HTMX frontend interaction, able to request particular PWs by link names and patch the DOM appropriately --- Purr.cabal | 4 +++- src/Core/HTTP.hs | 11 ++++++++-- src/Core/Mongo.hs | 30 ++------------------------- src/Core/Templates.hs | 12 ++++++----- src/Core/Types.hs | 1 - src/Feature/Handlers.hs | 23 --------------------- src/Feature/Sharing/HTTP.hs | 32 +++++++++++++++++++++++++++++ src/Feature/Sharing/Mongo.hs | 35 ++++++++++++++++++++++++++++++++ src/Feature/Sharing/Templates.hs | 16 +++++++++++++++ src/Lib.hs | 2 +- views/index.hamlet | 14 +++++++++---- views/pw.hamlet | 5 +++++ 12 files changed, 120 insertions(+), 65 deletions(-) delete mode 100644 src/Feature/Handlers.hs create mode 100644 src/Feature/Sharing/HTTP.hs create mode 100644 src/Feature/Sharing/Mongo.hs create mode 100644 src/Feature/Sharing/Templates.hs create mode 100644 views/pw.hamlet diff --git a/Purr.cabal b/Purr.cabal index a672501..8398a8e 100644 --- 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 index 4ce4c40..1b1a103 100644 --- 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 index fa97b6f..7fe3901 100644 --- 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 index 8b3f916..d150c55 100644 --- 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 index 91192e5..7704ee3 100644 --- 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 deleted file mode 100644 index 8c77ef4..0000000 --- a/src/Feature/Handlers.hs +++ /dev/null @@ -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 new file mode 100644 index 0000000..ee34e72 --- /dev/null +++ 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 new file mode 100644 index 0000000..c4b66fc --- /dev/null +++ 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 new file mode 100644 index 0000000..d1fd4b8 --- /dev/null +++ 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 index 7ea3dce..bd25ebd 100644 --- 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 index 865d18e..5085f4c 100644 --- a/views/index.hamlet +++ b/views/index.hamlet @@ -1,8 +1,14 @@ 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 new file mode 100644 index 0000000..9e611f4 --- /dev/null +++ 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}