Squashed commit of the following:

commit 9aaa5307e7671bc8bcc444733a6e38999f346772
Author: James Eversole <james@eversole.co>
Date:   Mon Jul 18 16:03:43 2022 -0500

    Completed migration to SQLite, full feature parity with original Mongo/Couch implementations. Added ability to submit new passwords with full frontend functionality. Generation of random links now functions as expected and Unix Epoch Timestamps are now included in DB entries.

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  

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

src/Feature/Sharing/Couch.hs

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

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)

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

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

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