diff --git a/Purr.cabal b/Purr.cabal index e584fa4..e1bdbba 100644 --- a/Purr.cabal +++ b/Purr.cabal @@ -20,12 +20,14 @@ extra-source-files: library exposed-modules: Core.Configuration - Core.Couch Core.HTTP + Core.SQLite Core.Templates Core.Types - Feature.Sharing.Couch + Feature.Generation.Links + Feature.Generation.Shared Feature.Sharing.HTTP + Feature.Sharing.SQLite Feature.Sharing.Templates Feature.Sharing.Types Lib @@ -42,18 +44,17 @@ library OverloadedStrings ScopedTypeVariables build-depends: - aeson >=2.0.0.0 - , base >=4.7 + base >=4.7 , blaze-html >=0.9.1.0 - , bytestring , containers , dhall >=1.40 && <1.41.2 , http-types >=0.12.3 , iso8601-time >=0.1.5 , mtl >=2.2.2 - , req >=3.10.0 + , random >=1.2 , scotty ==0.12 , shakespeare >=2.0.20 + , sqlite-simple >=0.4.18.0 , text >=1.2 , time >=1.9 , wai-extra >=3.1.12.1 @@ -76,18 +77,17 @@ executable Purr-exe ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: Purr - , aeson >=2.0.0.0 , base >=4.7 , blaze-html >=0.9.1.0 - , bytestring , containers , dhall >=1.40 && <1.41.2 , http-types >=0.12.3 , iso8601-time >=0.1.5 , mtl >=2.2.2 - , req >=3.10.0 + , random >=1.2 , scotty ==0.12 , shakespeare >=2.0.20 + , sqlite-simple >=0.4.18.0 , text >=1.2 , time >=1.9 , wai-extra >=3.1.12.1 @@ -111,18 +111,17 @@ test-suite Purr-test ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: Purr - , aeson >=2.0.0.0 , base >=4.7 , blaze-html >=0.9.1.0 - , bytestring , containers , dhall >=1.40 && <1.41.2 , http-types >=0.12.3 , iso8601-time >=0.1.5 , mtl >=2.2.2 - , req >=3.10.0 + , random >=1.2 , scotty ==0.12 , shakespeare >=2.0.20 + , sqlite-simple >=0.4.18.0 , text >=1.2 , time >=1.9 , wai-extra >=3.1.12.1 diff --git a/README.md b/README.md index 850d125..61674b8 100644 --- a/README.md +++ b/README.md @@ -13,7 +13,7 @@ You shouldn't! This is [free and open-source software](https://git.eversole.co/J ## Tech Stack? 1. [Haskell](https://www.haskell.org) and [Scotty](https://github.com/scotty-web/scotty) backend. 2. [HTMX](https://github.com/bigskysoftware/htmx) for the frontend. -3. [CouchDB](https://gitbox.apache.org/repos/asf?p=couchdb.git) database. +3. [SQLite](https://github.com/sqlite/sqlite) database. ## Project Goals 1. Provide a minimal and clean interface for generating and sharing passwords. diff --git a/package.yaml b/package.yaml index 2007235..9fe7444 100644 --- a/package.yaml +++ b/package.yaml @@ -28,18 +28,17 @@ default-extensions: description: https://git.eversole.co/James/Purr dependencies: -- aeson >= 2.0.0.0 - base >= 4.7 - blaze-html >= 0.9.1.0 -- bytestring - containers - dhall >= 1.40 && < 1.41.2 - http-types >= 0.12.3 - iso8601-time >= 0.1.5 - mtl >= 2.2.2 -- req >= 3.10.0 +- random >= 1.2 - scotty == 0.12 - shakespeare >= 2.0.20 +- sqlite-simple >= 0.4.18.0 - time >= 1.9 - text >= 1.2 - wai-extra >= 3.1.12.1 diff --git a/src/Core/Couch.hs b/src/Core/Couch.hs deleted file mode 100644 index 8e46b76..0000000 --- a/src/Core/Couch.hs +++ /dev/null @@ -1,79 +0,0 @@ -module Core.Couch where - -import Core.Types - -import Control.Monad.Reader (MonadIO, lift, ask) -import Data.Aeson -import Network.HTTP.Req as Req - -import qualified Data.Text as T -import qualified Data.ByteString.Char8 as B -import qualified Data.ByteString.Lazy.Char8 as LB - -getAllDBs :: PurrAction LbsResponse -getAllDBs = do - host <- dbHost - user <- dbUser - pw <- dbPassword - req - GET - (http host /: "_all_dbs") - NoReqBody - lbsResponse $ - basicAuthUnsafe user pw - <> - Req.port 5984 - -createDB :: (FromJSON a) => T.Text -> PurrAction (JsonResponse a) -createDB dbName = do - host <- dbHost - user <- dbUser - pw <- dbPassword - req - PUT - (http host /: dbName) - NoReqBody - jsonResponse $ - basicAuthUnsafe user pw - <> - Req.port 5984 - -getAllDocs :: PurrAction LbsResponse -getAllDocs = do - host <- dbHost - dbName <- confDb - user <- dbUser - pw <- dbPassword - req - GET - (http host /: dbName) - NoReqBody - lbsResponse $ - basicAuthUnsafe user pw - <> - Req.port 5984 - -confDb :: PurrAction T.Text -confDb = do - conf <- lift ask - return $ T.pack $ dataDB conf - -dbHost :: PurrAction T.Text -dbHost = do - conf <- lift ask - return $ T.pack $ couchHost conf - -dbPort :: PurrAction Int -dbPort = do - conf <- lift ask - return $ couchPort conf - -dbPassword :: PurrAction B.ByteString -dbPassword = do - conf <- lift ask - return $ B.pack $ couchPassword conf - -dbUser :: PurrAction B.ByteString -dbUser = do - conf <- lift ask - return $ B.pack $ couchUsername conf diff --git a/src/Core/SQLite.hs b/src/Core/SQLite.hs new file mode 100644 index 0000000..3db483f --- /dev/null +++ b/src/Core/SQLite.hs @@ -0,0 +1,24 @@ +module Core.SQLite where + +import Core.Types + +import Control.Monad.Reader (ask, lift, liftIO) +import Database.SQLite.Simple +import Database.SQLite.Simple.FromRow + +import qualified Data.Text as T + +main :: String -> IO () +main db = do + conn <- open db + execute_ conn + "CREATE TABLE IF NOT EXISTS pws\ + \ (link TEXT PRIMARY KEY,\ + \ secret TEXT,\ + \ date DATETIME DEFAULT CURRENT_TIMESTAMP)" + close conn + +dbPath :: PurrAction String +dbPath = do + conf <- lift ask + return $ dbFile conf diff --git a/src/Core/Templates.hs b/src/Core/Templates.hs index 3547d46..59d5e70 100644 --- a/src/Core/Templates.hs +++ b/src/Core/Templates.hs @@ -3,16 +3,18 @@ module Core.Templates ( renderIndex, renderStyle ) where -import Data.Text.Lazy (Text) import Text.Blaze.Html.Renderer.Text (renderHtml) import Text.Blaze.Html import Text.Cassius (cassiusFile, renderCss) import Text.Hamlet (shamletFile) +import qualified Data.Text as T +import qualified Data.Text.Lazy as LT + import Prelude -renderIndex :: String -> Maybe String -> Text +renderIndex :: String -> Maybe T.Text -> LT.Text renderIndex link password = renderHtml ( $(shamletFile "./views/index.hamlet") ) -renderStyle :: Text +renderStyle :: LT.Text renderStyle = renderCss ( $(cassiusFile "./views/cassius/style.cassius") "/style.css" ) diff --git a/src/Core/Types.hs b/src/Core/Types.hs index d8dea6b..0f36716 100644 --- a/src/Core/Types.hs +++ b/src/Core/Types.hs @@ -5,7 +5,6 @@ import qualified Data.Text.Lazy as LT import Control.Monad.Reader (MonadIO, MonadReader, ReaderT) import Data.Text import GHC.Generics (Generic) -import Network.HTTP.Req (HttpException, MonadHttp, handleHttpException) import Numeric.Natural (Natural) import Web.Scotty.Trans (ScottyT, ActionT) @@ -16,17 +15,9 @@ newtype ConfigM a = ConfigM { runConfigM :: ReaderT DhallConfig IO a } deriving (Applicative, Functor, Monad, MonadIO, MonadReader DhallConfig) -instance MonadHttp (ActionT LT.Text ConfigM) where - handleHttpException = error . show - data DhallConfig = DhallConfig { environment :: String , applicationHost :: String , applicationPort :: Int - , couchHost :: String - , couchPort :: Int - , couchUsername :: String - , couchPassword :: String - , adminDB :: String - , dataDB :: String + , dbFile :: String } deriving (Generic, Show) diff --git a/src/Feature/Generation/Links.hs b/src/Feature/Generation/Links.hs new file mode 100644 index 0000000..a8d6ed5 --- /dev/null +++ b/src/Feature/Generation/Links.hs @@ -0,0 +1,34 @@ +module Feature.Generation.Links ( genLink ) where + +import Core.Types +import Feature.Generation.Shared (rIndex) + +import Control.Monad.Reader (ask, lift, liftIO) +import Data.Char (toLower, toUpper) +import Data.List (foldl') +import System.IO +import System.Random + +genLink :: Int -> [Char] -> IO [Char] +genLink 0 cs = return cs +genLink d cs = do + res <- rChar + fin <- rCap res + genLink (d - 1) (cs <> (fin:[])) + +validChars :: [Char] +validChars = ['a'..'z'] <> ['1'..'9'] + +rChar :: IO Char +rChar = rIndex validChars + +rCap :: Char -> IO Char -- rCap takes a single character and returns it +rCap c = do -- capitalized or lowercased at random. + capRand <- randomRIO (0,1) + return $ checkRand capRand c + where + checkRand :: Int -> Char -> Char + checkRand r c + | r == 0 = toLower c + | r == 1 = toUpper c + | otherwise = c diff --git a/src/Feature/Generation/Shared.hs b/src/Feature/Generation/Shared.hs new file mode 100644 index 0000000..c46b3e3 --- /dev/null +++ b/src/Feature/Generation/Shared.hs @@ -0,0 +1,8 @@ +module Feature.Generation.Shared where + +import System.Random (randomRIO) + +rIndex :: [a] -> IO a +rIndex arr = do + i <- randomRIO (0, length arr - 1) + return $ arr !! i diff --git a/src/Feature/Sharing/Couch.hs b/src/Feature/Sharing/Couch.hs deleted file mode 100644 index 0bd1d79..0000000 --- a/src/Feature/Sharing/Couch.hs +++ /dev/null @@ -1,78 +0,0 @@ -module Feature.Sharing.Couch where - -import Core.Types -import Core.Couch (confDb, dbHost, dbPort, dbPassword, dbUser) -import Feature.Sharing.Types - -import Control.Monad.Reader (MonadIO, lift, ask) -import Data.Aeson -import Data.Maybe (fromJust) -import Data.Text.Encoding -import Network.HTTP.Req as Req - -import qualified Data.Text as T -import qualified Data.ByteString.Char8 as B -import qualified Data.ByteString.Lazy.Char8 as LB - -findByLink :: String -> PurrAction FindResults -findByLink link = do - host <- dbHost - dbName <- confDb - dbPort <- dbPort - user <- dbUser - pw <- dbPassword - res <- req - POST - (http host /: dbName /: "_find") - (ReqBodyJson postBody) - jsonResponse $ - basicAuthUnsafe user pw - <> - Req.port dbPort - return $ responseBody res - where - postBody :: Maybe Object - postBody = decodeStrict $ encodeUtf8 $ - "{\"selector\": {\"link\": {\"$eq\": \"" <> sanitizeQ link <> "\"}}}" - -{- -createNewSecret :: String -> PurrAction () -createNewSecret sec = do - host <- dbHost - dbName <- confDb - dbPort <- dbPort - user <- dbUser - pw <- dbPassword - res <- req - POST - (http host /: dbName) - (ReqBodyJson postBody) - jsonResponse $ - basicAuthUnsafe user pw - <> - Req.port dbPort - return $ responseBody res - where - postBody :: SecretEntry - postBody = SecretEntry - Nothing - Nothing - "notImplementedYet" - "zedNotImplementedYet" - sec --} - -findToSecret :: FindResults -> Maybe String -findToSecret doc = lookupSecret $ docs doc - where - lookupSecret :: [SecretEntry] -> Maybe String - lookupSecret [] = Nothing - lookupSecret (x:xs) = Just (secret x) - -sanitizeQ :: String -> T.Text -sanitizeQ s = T.pack $ map sanitizeQ' s - where - sanitizeQ' :: Char -> Char - sanitizeQ' '"' = ' ' - sanitizeQ' '\\' = ' ' - sanitizeQ' c = c diff --git a/src/Feature/Sharing/HTTP.hs b/src/Feature/Sharing/HTTP.hs index 6099497..a6f8245 100644 --- a/src/Feature/Sharing/HTTP.hs +++ b/src/Feature/Sharing/HTTP.hs @@ -3,13 +3,16 @@ module Feature.Sharing.HTTP ( routes ) where import Core.Types import Core.Templates (renderIndex) +import Feature.Generation.Links (genLink) +import Feature.Sharing.SQLite (findByLink, insertNewSecret) import Feature.Sharing.Templates (renderPw) -import Feature.Sharing.Couch (findByLink, findToSecret) +import Feature.Sharing.Types import qualified Data.Text as T import qualified Data.Text.Lazy as LT -import Control.Monad.Reader (ask, lift) +import Control.Monad.Reader (ask, lift, liftIO) +import Data.Maybe (listToMaybe) import Web.Scotty.Trans import Prelude @@ -17,11 +20,17 @@ routes :: PurrApp () routes = do get "/pw/:id" $ do - reqId <- param "id" - secretRes <- findByLink reqId - html $ renderIndex reqId (findToSecret secretRes) + reqId <- param "id" + res <- findByLink reqId + html $ renderIndex reqId (secret <$> res) post "/pw" $ do - reqId <- param "userLink" - secretRes <- findByLink reqId - html $ renderPw reqId (findToSecret secretRes) + reqId <- param "userLink" + res <- findByLink reqId + html $ renderPw reqId (secret <$> res) + + post "/new" $ do + reqSecret <- param "newSec" + link <- liftIO $ genLink 24 "" + insertNewSecret reqSecret (T.pack link) + html $ renderPw link (Just reqSecret) diff --git a/src/Feature/Sharing/SQLite.hs b/src/Feature/Sharing/SQLite.hs new file mode 100644 index 0000000..0b0a75e --- /dev/null +++ b/src/Feature/Sharing/SQLite.hs @@ -0,0 +1,35 @@ +module Feature.Sharing.SQLite where + +import Core.Types +import Core.SQLite +import Feature.Sharing.Types + +import Control.Monad.Reader (ask, lift, liftIO) +import Data.Maybe (listToMaybe) +import Data.Time.Clock.POSIX (getPOSIXTime) +import Database.SQLite.Simple +import Database.SQLite.Simple.FromRow + +import qualified Data.Text as T +import qualified Data.Text.Lazy as LT + +findByLink :: String -> PurrAction (Maybe SecretEntry) +findByLink link = do + db <- dbPath + conn <- liftIO $ open db + res <- liftIO $ query conn "SELECT * from pws WHERE link = ?" (Only link) + liftIO $ close conn + return $ listToMaybe res + +insertNewSecret :: T.Text -> T.Text -> PurrAction () +insertNewSecret sec link = do + db <- dbPath + conn <- liftIO $ open db + time <- liftIO $ epochTime + liftIO $ execute conn + "INSERT INTO pws (link, secret, date) VALUES (?, ?, ?)" + (SecretEntry link sec time) + liftIO $ close conn + +epochTime :: IO Integer +epochTime = fmap round getPOSIXTime diff --git a/src/Feature/Sharing/Templates.hs b/src/Feature/Sharing/Templates.hs index 6e60c8d..a5b92d2 100644 --- a/src/Feature/Sharing/Templates.hs +++ b/src/Feature/Sharing/Templates.hs @@ -3,6 +3,7 @@ module Feature.Sharing.Templates ( renderPw ) where +import qualified Data.Text as T import qualified Data.Text.Lazy as LT import Text.Blaze.Html.Renderer.Text (renderHtml) @@ -11,5 +12,5 @@ import Text.Hamlet (shamletFile) import Prelude -renderPw :: String -> Maybe String -> LT.Text +renderPw :: String -> Maybe T.Text -> LT.Text renderPw link password = renderHtml ( $(shamletFile "./views/pw.hamlet") ) diff --git a/src/Feature/Sharing/Types.hs b/src/Feature/Sharing/Types.hs index b1be568..c144cab 100644 --- a/src/Feature/Sharing/Types.hs +++ b/src/Feature/Sharing/Types.hs @@ -1,28 +1,19 @@ module Feature.Sharing.Types where -import Data.Aeson import Data.Map.Strict (Map) import Data.Typeable (Typeable) import GHC.Generics -data SecretEntry = SecretEntry - { _id :: Maybe String - , _rev :: Maybe String - , creationTime :: String - , link :: String - , secret :: String - } deriving (Generic, Show, Typeable) +import Database.SQLite.Simple +import Database.SQLite.Simple.FromRow -data FindResults = FindResults - { bookmark :: String - , docs :: [SecretEntry] - , warning :: Maybe String - } deriving (Generic, Show, Typeable) +import qualified Data.Text as T -instance ToJSON SecretEntry where - toEncoding = genericToEncoding defaultOptions -instance ToJSON FindResults where - toEncoding = genericToEncoding defaultOptions +data SecretEntry = SecretEntry + { link :: T.Text + , secret :: T.Text + , date :: Integer + } deriving (Show, Generic) -instance FromJSON SecretEntry -instance FromJSON FindResults +instance FromRow SecretEntry where +instance ToRow SecretEntry where diff --git a/src/Lib.hs b/src/Lib.hs index 245aa0c..7946d48 100644 --- a/src/Lib.hs +++ b/src/Lib.hs @@ -2,10 +2,10 @@ module Lib ( main ) where import qualified Core.Configuration as Configuration import qualified Core.HTTP as HTTP -import qualified Core.Couch as DB +import qualified Core.SQLite as DB import Core.Types -import Control.Monad.Reader (liftIO, runReaderT) +import Control.Monad.Reader (lift, liftIO, runReaderT) import GHC.Natural (popCountNatural) import Prelude hiding (id) import Web.Scotty.Trans (scottyT) @@ -13,6 +13,7 @@ import Web.Scotty.Trans (scottyT) main :: IO () main = do dhallConf <- liftIO Configuration.main + DB.main (dbFile dhallConf) scottyT (applicationPort dhallConf) (flip runApp dhallConf) HTTP.app where runApp :: ConfigM a -> DhallConfig -> IO a runApp m = runReaderT (runConfigM m) diff --git a/views/index.hamlet b/views/index.hamlet index 341c9d1..958cf25 100644 --- a/views/index.hamlet +++ b/views/index.hamlet @@ -30,15 +30,15 @@ $doctype 5