110 lines
4.0 KiB
Haskell
110 lines
4.0 KiB
Haskell
module Feature.Sharing.SQLite where
|
|
|
|
import Core.SQLite
|
|
import Core.Types
|
|
import Feature.Generation.Passwords (Password)
|
|
|
|
import Control.Monad.Reader (ask, lift, liftIO)
|
|
import Data.List.Split (splitOn)
|
|
import Data.Maybe (listToMaybe, fromMaybe, Maybe(Just))
|
|
import Data.Time.Clock.POSIX (getPOSIXTime)
|
|
import Database.SQLite.Simple
|
|
|
|
import qualified Crypto.Saltine.Core.SecretBox as Box
|
|
import qualified Crypto.Saltine.Class as CL
|
|
import qualified Data.ByteString.Base64 as B64
|
|
import qualified Data.ByteString.Char8 as BSC8
|
|
import qualified Data.ByteString as B
|
|
import qualified Data.Text as T
|
|
import qualified Data.Text.Encoding as ET
|
|
import qualified Data.Text.Lazy as LT
|
|
|
|
findByLink :: String -> PurrAction (Maybe T.Text)
|
|
findByLink link = do
|
|
db <- dbPath
|
|
key <- liftIO encKey
|
|
conn <- liftIO $ open db
|
|
res <- liftIO $ query conn "SELECT * from pws WHERE link = ?" (Only (last $ splitOn "/" link))
|
|
liftIO $ close conn
|
|
readEncryptedSecret key res
|
|
|
|
insertNewSecret :: T.Text -> Integer -> T.Text -> Integer -> PurrAction ()
|
|
insertNewSecret sec life link maxViews = do
|
|
db <- dbPath
|
|
key <- liftIO encKey
|
|
nonce <- liftIO $ Box.newNonce
|
|
let encSec = encryptSecret key sec nonce
|
|
conn <- liftIO $ open db
|
|
time <- liftIO $ epochTime
|
|
liftIO $ execute conn
|
|
"INSERT INTO pws (link, secret, nonce, date, life, views, maxViews) VALUES (?, ?, ?, ?, ?, ?, ?)"
|
|
(SecretEntry link (encodeSecret encSec) (CL.encode nonce) time life 0 maxViews)
|
|
liftIO $ close conn
|
|
|
|
readEncryptedSecret :: B.ByteString -> [SecretEntry] -> PurrAction (Maybe T.Text)
|
|
readEncryptedSecret key sec = do
|
|
db <- dbPath
|
|
let secNonce = nonce $ safeHead failedSecret sec
|
|
liftIO $ incViews sec db
|
|
delete <- liftIO $ deleteExpiredSecret sec db
|
|
let decSec = decryptSecret key secNonce $ decodeSecret $ safeHead failedSecret sec
|
|
if (delete)
|
|
then return Nothing
|
|
else return (ET.decodeLatin1 <$> decSec)
|
|
where
|
|
incViews :: [SecretEntry] -> String -> IO ()
|
|
incViews [] _ = return ()
|
|
incViews (sec : _) db = do
|
|
conn <- liftIO $ open db
|
|
liftIO $ execute conn
|
|
"UPDATE pws SET views = views + 1 WHERE link = ?" (Only (link sec))
|
|
liftIO $ close conn
|
|
|
|
-- Returns True if deletion occurs, informing the caller to not provide
|
|
-- the successfully retrieved secret to the requestor.
|
|
deleteExpiredSecret :: [SecretEntry] -> String -> IO Bool
|
|
deleteExpiredSecret [] _ = return False
|
|
deleteExpiredSecret (sec : _) db = do
|
|
time <- liftIO $ epochTime
|
|
if ((date sec) + ((life sec) * 86400) < time) || (views sec >= maxViews sec)
|
|
then deleteSec sec db
|
|
else return False
|
|
where
|
|
deleteSec :: SecretEntry -> String -> IO Bool
|
|
deleteSec sec db = do
|
|
conn <- liftIO $ open db
|
|
liftIO $ execute conn
|
|
"DELETE FROM pws WHERE link = ?" (Only (link sec))
|
|
liftIO $ close conn
|
|
return True
|
|
|
|
encodeSecret :: B.ByteString -> T.Text
|
|
encodeSecret b = ET.decodeUtf8 $ B64.encode b
|
|
|
|
decodeSecret :: SecretEntry -> B.ByteString
|
|
decodeSecret s = B64.decodeLenient $ ET.encodeUtf8 (secret s)
|
|
|
|
encryptSecret :: B.ByteString -> T.Text -> Box.Nonce -> B.ByteString
|
|
encryptSecret k s n = do
|
|
case (CL.decode k) of
|
|
(Just key) -> Box.secretbox key n (ET.encodeUtf8 s)
|
|
Nothing -> error "fail"
|
|
|
|
decryptSecret :: B.ByteString -> B.ByteString -> B.ByteString -> Maybe B.ByteString
|
|
decryptSecret k n b = do
|
|
case (CL.decode k) of
|
|
(Just key) -> case (CL.decode n) of
|
|
(Just nonce) -> Box.secretboxOpen key nonce b
|
|
Nothing -> error "Failed to decode nonce"
|
|
Nothing -> error "Failed to decode secret key"
|
|
|
|
epochTime :: IO Integer
|
|
epochTime = fmap round getPOSIXTime
|
|
|
|
failedSecret :: SecretEntry
|
|
failedSecret = SecretEntry "fail" "fail" (BSC8.pack "fail") 0 0 0 0
|
|
|
|
safeHead :: a -> [a] -> a
|
|
safeHead x [] = x
|
|
safeHead x l = head l
|