intricacy-0.8.0.1: Database.hs
-- This file is part of Intricacy
-- Copyright (C) 2013 Martin Bays <mbays@sdf.org>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of version 3 of the GNU General Public License as
-- published by the Free Software Foundation, or any later version.
--
-- You should have received a copy of the GNU General Public License
-- along with this program. If not, see http://www.gnu.org/licenses/.
module Database where
import Control.Applicative
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Reader
import qualified Data.ByteString.Char8 as CS
import qualified Data.ByteString.Lazy.Char8 as CL
import Data.Char (toUpper)
import Data.Maybe
import Data.Tuple (swap)
import System.Directory
import System.FilePath
import System.IO
import Crypto.Hash (Digest, SHA1, hashlazy)
import Crypto.PubKey.RSA.Types (PrivateKey, PublicKey)
import Data.ByteArray.Encoding (Base (..), convertToBase)
import Lock
import Metagame
import Mundanities
import Protocol
sha1 :: CL.ByteString -> Digest SHA1
sha1 = hashlazy
hash :: String -> String
hash = CS.unpack . digestToHexByteString . sha1 . CL.pack
where digestToHexByteString = convertToBase Base16
data Record
= RecPasswordLegacy Codename
| RecPasswordArgon2 Codename
| RecEmail Codename
| RecUserInfo Codename
| RecUserInfoLog Codename
| RecLock LockSpec
| RecNote NoteInfo
| RecLockHashes
| RecRetiredLocks Codename
| RecServerInfo
| RecServerEmail
| RecPublicKey
| RecSecretKey
deriving (Eq, Ord, Show)
data RecordContents
= RCPasswordLegacy Password
| RCPasswordArgon2 String
| RCUserInfo VersionedUInfo
| RCUserInfoDeltas [UserInfoDelta]
| RCLock Lock
| RCSolution Solution
| RCLockHashes [String]
| RCLockSpecs [LockSpec]
| RCServerInfo ServerInfo
| RCEmail CS.ByteString
| RCPublicKey PublicKey
| RCSecretKey PrivateKey
deriving (Eq, Show)
rcOfServerResp (ServedServerInfo x) = RCServerInfo x
rcOfServerResp (ServedLock x) = RCLock x
rcOfServerResp (ServedSolution x) = RCSolution x
rcOfServerResp (ServedUserInfo x) = RCUserInfo x
rcOfServerResp (ServedRetired x) = RCLockSpecs x
rcOfServerResp (ServedPublicKey x) = RCPublicKey x
rcOfServerResp _ = error "no corresponding rc"
invariantRecord (RecUserInfo _) = False
invariantRecord (RecUserInfoLog _) = False
invariantRecord (RecPasswordLegacy _) = False
invariantRecord (RecPasswordArgon2 _) = False
invariantRecord (RecRetiredLocks _) = False
invariantRecord (RecNote _) = False
invariantRecord (RecEmail _) = False
invariantRecord _ = True
askForRecord RecServerInfo = GetServerInfo
askForRecord (RecUserInfo name) = GetUserInfo name Nothing
askForRecord (RecLock ls) = GetLock ls
askForRecord (RecNote note) = GetSolution note
askForRecord (RecRetiredLocks name) = GetRetired name
askForRecord RecPublicKey = GetPublicKey
askForRecord _ = error "no corresponding request"
type DBM = ReaderT FilePath IO
withDB :: FilePath -> DBM a -> IO a
withDB = flip runReaderT
recordExists :: Record -> DBM Bool
recordExists rec = recordPath rec >>= liftIO . doesFileExist
getRecord :: Record -> DBM (Maybe RecordContents)
getRecord rec = do
path <- recordPath rec
liftIO . ignoreIOErrAlt $ do
h <- openFile path ReadMode
getRecordh rec h <* hClose h
getRecordh (RecPasswordLegacy _) h = (RCPasswordLegacy <$>) . tryRead <$> hGetStrict h
getRecordh (RecPasswordArgon2 _) h = (RCPasswordArgon2 <$>) . tryRead <$> hGetStrict h
getRecordh (RecEmail _) h = (RCEmail <$>) . tryRead <$> hGetStrict h
getRecordh (RecUserInfo _) h = (RCUserInfo <$>) . tryRead <$> hGetStrict h
getRecordh (RecUserInfoLog _) h = (RCUserInfoDeltas <$>) . tryRead <$> hGetStrict h
getRecordh (RecLock _) h = (RCLock <$>) . tryRead <$> hGetStrict h
getRecordh (RecNote _) h = (RCSolution <$>) . tryRead <$> hGetStrict h
getRecordh RecLockHashes h = (RCLockHashes <$>) . tryRead <$> hGetStrict h
getRecordh (RecRetiredLocks name) h = (RCLockSpecs <$>) . tryRead <$> hGetStrict h
getRecordh RecServerInfo h = (RCServerInfo <$>) . tryRead <$> hGetStrict h
getRecordh RecServerEmail h = (RCEmail <$>) . tryRead <$> hGetStrict h
getRecordh RecPublicKey h = (RCPublicKey <$>) . tryRead <$> hGetStrict h
getRecordh RecSecretKey h = (RCSecretKey <$>) . tryRead <$> hGetStrict h
hGetStrict h = CS.unpack <$> concatMWhileNonempty (repeat $ CS.hGet h 1024)
where concatMWhileNonempty (m:ms) = do
bs <- m
if CS.null bs
then return bs
else (bs `CS.append`) <$> concatMWhileNonempty ms
putRecord :: Record -> RecordContents -> DBM ()
putRecord rec rc = do
path <- recordPath rec
liftIO $ do
mkdirhierto path
h <- openFile path WriteMode
putRecordh rc h
hClose h
putRecordh (RCPasswordLegacy hpw) h = hPutStr h $ show hpw
putRecordh (RCPasswordArgon2 hpw) h = hPutStr h $ show hpw
putRecordh (RCEmail addr) h = hPutStr h $ show addr
putRecordh (RCUserInfo info) h = hPutStr h $ show info
putRecordh (RCUserInfoDeltas deltas) h = hPutStr h $ show deltas
putRecordh (RCLock lock) h = hPutStr h $ show lock
putRecordh (RCSolution solution) h = hPutStr h $ show solution
putRecordh (RCLockHashes hashes) h = hPutStr h $ show hashes
putRecordh (RCLockSpecs lss) h = hPutStr h $ show lss
putRecordh (RCServerInfo sinfo) h = hPutStr h $ show sinfo
putRecordh (RCPublicKey publicKey) h = hPutStr h $ show publicKey
putRecordh (RCSecretKey secretKey) h = hPutStr h $ show secretKey
modifyRecord :: Record -> (RecordContents -> RecordContents) -> DBM ()
modifyRecord rec f = do
h <- recordPath rec >>= liftIO . flip openFile ReadWriteMode
liftIO $ do
Just rc <- getRecordh rec h
hSeek h AbsoluteSeek 0
putRecordh (f rc) h
hTell h >>= hSetFileSize h
hClose h
delRecord :: Record -> DBM ()
delRecord rec = recordPath rec >>= liftIO . removeFile
newLockRecord :: Lock -> DBM LockSpec
newLockRecord lock = do
dbpath <- ask
let path = dbpath++[pathSeparator]++"lastlock"
h <- liftIO $ openFile path ReadWriteMode
contents <- liftIO $ hGetStrict h
let ls = if null contents then 0 else 1 + read contents
liftIO $ hSeek h AbsoluteSeek 0
liftIO $ hPutStr h $ show ls
liftIO $ hClose h
putRecord (RecLock ls) (RCLock lock)
return ls
listUsers :: DBM [Codename]
listUsers = do
dbpath <- ask
liftIO $ (unpathifyName <$>) . filter ((==3).length) <$>
getDirectoryContents (dbpath++[pathSeparator]++"users")
recordPath :: Record -> DBM FilePath
recordPath rec =
(++ (pathSeparator : recordPath' rec)) <$> ask
where
recordPath' (RecPasswordLegacy name) = userDir name ++ "passwd"
recordPath' (RecPasswordArgon2 name) = userDir name ++ "passwd_argon2"
recordPath' (RecEmail name) = userDir name ++ "email"
recordPath' (RecUserInfo name) = userDir name ++ "info"
recordPath' (RecUserInfoLog name) = userDir name ++ "log"
recordPath' (RecLock ls) = locksDir ++ show ls
recordPath' (RecNote (NoteInfo name _ alock)) =
userDir name ++ "notes" ++ [pathSeparator] ++ alockFN alock
recordPath' (RecRetiredLocks name) = userDir name ++ "retired"
recordPath' RecLockHashes = "lockHashes"
recordPath' RecServerInfo = "serverInfo"
recordPath' RecServerEmail = "serverEmail"
recordPath' RecPublicKey = "publicKey"
recordPath' RecSecretKey = "secretKey"
userDir name = "users" ++ [pathSeparator] ++ pathifyName name ++ [pathSeparator]
alockFN (ActiveLock name idx) = pathifyName name ++":"++ show idx
locksDir = "locks"++[pathSeparator]
pathifyName = winSux . dummyPunctuation
-- | Hilariously, "CON", "PRN", "AUX", and "NUL" are reserved on DOS, and
-- Windows apparently crashes rather than write a directory with that name!
winSux name = if (toUpper <$> name) `elem` ["CON","PRN", "AUX","NUL"]
then '_':name
else name
-- | Dummy out characters which are disallowed on unix or dos.
-- We use lowercase characters as dummies.
-- To avoid collisions on case-insensitive filesystems, we use '_' as an
-- escape character.
dummyPunctuation = concatMap $ \c ->
maybe [c] (('_':) . pure) (lookup c pathifyAssocs)
unpathifyName = concatMap $ \c -> case c of
'_' -> ""
_ -> pure $ fromMaybe c (lookup c $ swap <$> pathifyAssocs)
pathifyAssocs =
[ ('/','s')
, ('.','d')
, ('\\','b')
, ('<','l')
, ('>','g')
, (':','c')
, ('|','p')
, ('?','q')
, ('*','a')
, ('+','t')
, (',','m')
, (';','i')
, ('=','e')
, ('[','k')
, (']','j')
, ('_','u')
]