SQLite.hs (5004B)
1 module Feature.Sharing.SQLite where 2 3 import Core.Configuration 4 import Core.SQLite 5 import Core.Types 6 import Feature.Generation.Passwords (Password) 7 8 import Control.Monad.Trans (liftIO) 9 import Data.List.Split (splitOn) 10 import Data.Maybe (listToMaybe, fromMaybe, Maybe(Just)) 11 import Data.Time.Clock.POSIX (getPOSIXTime) 12 import Database.SQLite.Simple 13 14 import qualified Crypto.Saltine.Core.SecretBox as Box 15 import qualified Crypto.Saltine.Class as CL 16 import qualified Data.ByteString.Base64 as B64 17 import qualified Data.ByteString.Char8 as BSC8 18 import qualified Data.ByteString as B 19 import qualified Data.Text as T 20 import qualified Data.Text.Encoding as ET 21 import qualified Data.Text.Lazy as LT 22 23 -- Look up a secret based on the "link" attribute 24 findByLink :: String -> PurrAction (Maybe T.Text) 25 findByLink link = do 26 -- Get the encryption key from the filesystem as a ByteString 27 key <- liftIO encKey 28 -- Start up a connection to the SQLite database 29 conn <- liftIO $ open dbPath 30 -- Constant containing the results of a query looking for the "link" attribute 31 res <- liftIO $ 32 query conn "SELECT * from pws WHERE link = ?" 33 (Only (last $ splitOn "/" link)) 34 -- Close the SQLite database connection 35 liftIO $ close conn 36 -- Pass the encryption key and [SecretEntry] to be unencrypted 37 readEncryptedSecret key res 38 39 readEncryptedSecret :: B.ByteString -> [SecretEntry] -> PurrAction (Maybe T.Text) 40 readEncryptedSecret key [] = return Nothing 41 readEncryptedSecret key (secret:_) = do 42 -- Increment the number of views on the secret in the database by one 43 liftIO $ incViews secret dbPath 44 -- Delete the secret if it's expired 45 delete <- liftIO $ deleteExpiredSecret secret dbPath 46 if (delete) 47 -- Don't return the secret if it's expired 48 then return Nothing 49 -- Otherwise, try to decrypt and return it 50 else return (ET.decodeLatin1 <$> 51 (decryptSecret key (nonce secret) $ decodeSecret secret)) 52 where 53 incViews :: SecretEntry -> String -> IO () 54 incViews secret dbPath = do 55 conn <- open dbPath 56 execute conn 57 "UPDATE pws SET views = views + 1 WHERE link = ?" (Only (link secret)) 58 close conn 59 60 deleteExpiredSecret :: SecretEntry -> String -> IO Bool 61 deleteExpiredSecret sec dbPath = do 62 -- Get the current Unix Epoch time in seconds 63 time <- epochTime 64 -- Compare the current time against the secret's initial insertion and lifetime 65 if ((date sec) + ((life sec) * 86400) < time) || (views sec >= maxViews sec) 66 -- Delete the secret if it's expired and return True for the caller 67 then deleteSec sec dbPath 68 -- Only return False if the secret is not expired 69 else return False 70 where 71 deleteSec :: SecretEntry -> String -> IO Bool 72 deleteSec sec dbPath = do 73 conn <- open dbPath 74 execute conn 75 "DELETE FROM pws WHERE link = ?" (Only (link sec)) 76 close conn 77 return True 78 79 insertNewSecret :: T.Text -> Integer -> T.Text -> Integer -> PurrAction () 80 insertNewSecret sec life link maxViews = do 81 key <- liftIO encKey 82 -- Create a new nonce to associate with the secret's encryption 83 nonce <- liftIO Box.newNonce 84 {- Encrypt the secret; this is a pure function because we seeded RNG at program 85 initialization with "sodiumInit" -} 86 let encSec = encryptSecret key sec nonce 87 conn <- liftIO $ open dbPath 88 -- Get the current time to timestamp the secret's initial insertion 89 time <- liftIO epochTime 90 -- Save the secret to the database 91 liftIO $ execute conn 92 "INSERT INTO pws (link, secret, nonce, date, life, views, maxViews) VALUES (?, ?, ?, ?, ?, ?, ?)" 93 (SecretEntry link (encodeSecret encSec) (CL.encode nonce) time life 0 maxViews) 94 liftIO $ close conn 95 96 encodeSecret :: B.ByteString -> T.Text 97 encodeSecret b = ET.decodeUtf8 $ B64.encode b 98 99 decodeSecret :: SecretEntry -> B.ByteString 100 decodeSecret s = B64.decodeLenient $ ET.encodeUtf8 (secret s) 101 102 encryptSecret :: B.ByteString -> T.Text -> Box.Nonce -> B.ByteString 103 encryptSecret k s n = do 104 case (CL.decode k) of 105 (Just key) -> Box.secretbox key n (ET.encodeUtf8 s) 106 Nothing -> error "fail" 107 108 decryptSecret :: B.ByteString -> B.ByteString -> B.ByteString -> Maybe B.ByteString 109 decryptSecret k n b = do 110 case (CL.decode k) of 111 (Just key) -> case (CL.decode n) of 112 (Just nonce) -> Box.secretboxOpen key nonce b 113 {- There's no sensible way to fail gracefully if our nonce or secret 114 key can't be decoded. Throw an error so the instance admin can 115 investigate -} 116 Nothing -> error "Failed to decode nonce" 117 Nothing -> error "Failed to decode secret key" 118 119 -- Helper function to provide the current Epoch Time in seconds 120 epochTime :: IO Integer 121 epochTime = fmap round getPOSIXTime