intricacy-0.7.1.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 Data.Maybe
import Data.Tuple (swap)
import Data.Char (toUpper)
import Control.Applicative
import Control.Monad
import System.IO
import System.FilePath
import System.Directory
import Control.Monad.Trans.Reader
import Control.Monad.IO.Class
import qualified Data.ByteString.Lazy.Char8 as CL
import qualified Data.ByteString.Char8 as CS
import Crypto.Hash (hashlazy, Digest, SHA1, digestToHexByteString)
import Crypto.Types.PubKey.RSA (PublicKey, PrivateKey)
import Protocol
import Metagame
import Lock
import Mundanities
sha1 :: CL.ByteString -> Digest SHA1
sha1 = hashlazy
hash :: String -> String
hash = CS.unpack . digestToHexByteString . sha1 . CL.pack
data Record
= RecPassword Codename
| RecEmail Codename
| RecUserInfo Codename
| RecUserInfoLog Codename
| RecLock LockSpec
| RecNote NoteInfo
| RecLockHashes
| RecRetiredLocks Codename
| RecServerInfo
| RecServerEmail
| RecPublicKey
| RecSecretKey
deriving (Eq, Ord, Show)
data RecordContents
= RCPassword Password
| 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 (RecPassword _) = 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 $ flip catchIO (const $ return Nothing) $ do
h <- openFile path ReadMode
getRecordh rec h <* hClose h
getRecordh (RecPassword _) h = ((RCPassword <$>) . 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 (RCPassword 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 $ (map unpathifyName . filter ((==3).length)) <$>
getDirectoryContents (dbpath++[pathSeparator]++"users")
recordPath :: Record -> DBM FilePath
recordPath rec =
(++ ([pathSeparator] ++ recordPath' rec)) <$> ask
where
recordPath' (RecPassword name) = userDir name ++ "passwd"
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 map 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 ->
fromMaybe [c] (('_':) . pure <$> lookup c pathifyAssocs)
unpathifyName = concatMap $ \c -> case c of
'_' -> ""
_ -> pure $ fromMaybe c (lookup c $ map swap pathifyAssocs)
pathifyAssocs =
[ ('/','s')
, ('.','d')
, ('\\','b')
, ('<','l')
, ('>','g')
, (':','c')
, ('|','p')
, ('?','q')
, ('*','a')
, ('+','t')
, (',','m')
, (';','i')
, ('=','e')
, ('[','k')
, (']','j')
, ('_','u')
]