Database.hs

   1 -- This file is part of Intricacy
   2 -- Copyright (C) 2013 Martin Bays <mbays@sdf.org>
   3 --
   4 -- This program is free software: you can redistribute it and/or modify
   5 -- it under the terms of version 3 of the GNU General Public License as
   6 -- published by the Free Software Foundation, or any later version.
   7 --
   8 -- You should have received a copy of the GNU General Public License
   9 -- along with this program.  If not, see http://www.gnu.org/licenses/.
  10
  11 module Database where
  12
  13 import           Control.Applicative
  14 import           Control.Monad
  15 import           Control.Monad.IO.Class
  16 import           Control.Monad.Trans.Reader
  17 import qualified Data.ByteString.Char8      as CS
  18 import qualified Data.ByteString.Lazy.Char8 as CL
  19 import           Data.Char                  (toUpper)
  20 import           Data.Maybe
  21 import           Data.Tuple                 (swap)
  22 import           System.Directory
  23 import           System.FilePath
  24 import           System.IO
  25
  26 import           Crypto.Hash                (Digest, SHA1,
  27                                              digestToHexByteString, hashlazy)
  28 import           Crypto.Types.PubKey.RSA    (PrivateKey, PublicKey)
  29
  30 import           Lock
  31 import           Metagame
  32 import           Mundanities
  33 import           Protocol
  34
  35 sha1 :: CL.ByteString -> Digest SHA1
  36 sha1 = hashlazy
  37 hash :: String -> String
  38 hash = CS.unpack . digestToHexByteString . sha1 . CL.pack
  39
  40 data Record
  41     = RecPasswordLegacy Codename
  42     | RecPasswordArgon2 Codename
  43     | RecEmail Codename
  44     | RecUserInfo Codename
  45     | RecUserInfoLog Codename
  46     | RecLock LockSpec
  47     | RecNote NoteInfo
  48     | RecLockHashes
  49     | RecRetiredLocks Codename
  50     | RecServerInfo
  51     | RecServerEmail
  52     | RecPublicKey
  53     | RecSecretKey
  54     deriving (Eq, Ord, Show)
  55 data RecordContents
  56     = RCPasswordLegacy Password
  57     | RCPasswordArgon2 String
  58     | RCUserInfo VersionedUInfo
  59     | RCUserInfoDeltas [UserInfoDelta]
  60     | RCLock Lock
  61     | RCSolution Solution
  62     | RCLockHashes [String]
  63     | RCLockSpecs [LockSpec]
  64     | RCServerInfo ServerInfo
  65     | RCEmail CS.ByteString
  66     | RCPublicKey PublicKey
  67     | RCSecretKey PrivateKey
  68     deriving (Eq, Show)
  69
  70 rcOfServerResp (ServedServerInfo x) = RCServerInfo x
  71 rcOfServerResp (ServedLock x)       = RCLock x
  72 rcOfServerResp (ServedSolution x)   = RCSolution x
  73 rcOfServerResp (ServedUserInfo x)   = RCUserInfo x
  74 rcOfServerResp (ServedRetired x)    = RCLockSpecs x
  75 rcOfServerResp (ServedPublicKey x)  = RCPublicKey x
  76 rcOfServerResp _                    = error "no corresponding rc"
  77
  78 invariantRecord (RecUserInfo _)       = False
  79 invariantRecord (RecUserInfoLog _)    = False
  80 invariantRecord (RecPasswordLegacy _) = False
  81 invariantRecord (RecPasswordArgon2 _) = False
  82 invariantRecord (RecRetiredLocks _)   = False
  83 invariantRecord (RecNote _)           = False
  84 invariantRecord (RecEmail _)          = False
  85 invariantRecord _                     = True
  86
  87 askForRecord RecServerInfo          = GetServerInfo
  88 askForRecord (RecUserInfo name)     = GetUserInfo name Nothing
  89 askForRecord (RecLock ls)           = GetLock ls
  90 askForRecord (RecNote note)         = GetSolution note
  91 askForRecord (RecRetiredLocks name) = GetRetired name
  92 askForRecord RecPublicKey           = GetPublicKey
  93 askForRecord _                      = error "no corresponding request"
  94
  95 type DBM = ReaderT FilePath IO
  96 withDB :: FilePath -> DBM a -> IO a
  97 withDB = flip runReaderT
  98
  99 recordExists :: Record -> DBM Bool
 100 recordExists rec = recordPath rec >>= liftIO . doesFileExist
 101
 102 getRecord :: Record -> DBM (Maybe RecordContents)
 103 getRecord rec = do
 104     path <- recordPath rec
 105     liftIO . ignoreIOErrAlt $ do
 106         h <- openFile path ReadMode
 107         getRecordh rec h <* hClose h
 108 getRecordh (RecPasswordLegacy _) h = (RCPasswordLegacy <$>) . tryRead <$> hGetStrict h
 109 getRecordh (RecPasswordArgon2 _) h = (RCPasswordArgon2 <$>) . tryRead <$> hGetStrict h
 110 getRecordh (RecEmail _) h = (RCEmail <$>) . tryRead <$> hGetStrict h
 111 getRecordh (RecUserInfo _) h = (RCUserInfo <$>) . tryRead <$> hGetStrict h
 112 getRecordh (RecUserInfoLog _) h = (RCUserInfoDeltas <$>) . tryRead <$> hGetStrict h
 113 getRecordh (RecLock _) h = (RCLock <$>) . tryRead <$> hGetStrict h
 114 getRecordh (RecNote _) h = (RCSolution <$>) . tryRead <$> hGetStrict h
 115 getRecordh RecLockHashes h = (RCLockHashes <$>) . tryRead <$> hGetStrict h
 116 getRecordh (RecRetiredLocks name) h = (RCLockSpecs <$>) . tryRead <$> hGetStrict h
 117 getRecordh RecServerInfo h = (RCServerInfo <$>) . tryRead <$> hGetStrict h
 118 getRecordh RecServerEmail h = (RCEmail <$>) . tryRead <$> hGetStrict h
 119 getRecordh RecPublicKey h = (RCPublicKey <$>) . tryRead <$> hGetStrict h
 120 getRecordh RecSecretKey h = (RCSecretKey <$>) . tryRead <$> hGetStrict h
 121
 122 hGetStrict h = CS.unpack <$> concatMWhileNonempty (repeat $ CS.hGet h 1024)
 123     where concatMWhileNonempty (m:ms) = do
 124             bs <- m
 125             if CS.null bs
 126                 then return bs
 127                 else (bs `CS.append`) <$> concatMWhileNonempty ms
 128
 129 putRecord :: Record -> RecordContents -> DBM ()
 130 putRecord rec rc = do
 131     path <- recordPath rec
 132     liftIO $ do
 133         mkdirhierto path
 134         h <- openFile path WriteMode
 135         putRecordh rc h
 136         hClose h
 137 putRecordh (RCPasswordLegacy hpw) h    = hPutStr h $ show hpw
 138 putRecordh (RCPasswordArgon2 hpw) h    = hPutStr h $ show hpw
 139 putRecordh (RCEmail addr) h            = hPutStr h $ show addr
 140 putRecordh (RCUserInfo info) h         = hPutStr h $ show info
 141 putRecordh (RCUserInfoDeltas deltas) h = hPutStr h $ show deltas
 142 putRecordh (RCLock lock) h             = hPutStr h $ show lock
 143 putRecordh (RCSolution solution) h     = hPutStr h $ show solution
 144 putRecordh (RCLockHashes hashes) h     = hPutStr h $ show hashes
 145 putRecordh (RCLockSpecs lss) h         = hPutStr h $ show lss
 146 putRecordh (RCServerInfo sinfo) h      = hPutStr h $ show sinfo
 147 putRecordh (RCPublicKey publicKey) h   = hPutStr h $ show publicKey
 148 putRecordh (RCSecretKey secretKey) h   = hPutStr h $ show secretKey
 149
 150 modifyRecord :: Record -> (RecordContents -> RecordContents) -> DBM ()
 151 modifyRecord rec f = do
 152     h <- recordPath rec >>= liftIO . flip openFile ReadWriteMode
 153     liftIO $ do
 154         Just rc <- getRecordh rec h
 155         hSeek h AbsoluteSeek 0
 156         putRecordh (f rc) h
 157         hTell h >>= hSetFileSize h
 158         hClose h
 159
 160 delRecord :: Record -> DBM ()
 161 delRecord rec = recordPath rec >>= liftIO . removeFile
 162
 163 newLockRecord :: Lock -> DBM LockSpec
 164 newLockRecord lock = do
 165     dbpath <- ask
 166     let path = dbpath++[pathSeparator]++"lastlock"
 167     h <- liftIO $ openFile path ReadWriteMode
 168     contents <- liftIO $ hGetStrict h
 169     let ls = if null contents then 0 else 1 + read contents
 170     liftIO $ hSeek h AbsoluteSeek 0
 171     liftIO $ hPutStr h $ show ls
 172     liftIO $ hClose h
 173     putRecord (RecLock ls) (RCLock lock)
 174     return ls
 175
 176 listUsers :: DBM [Codename]
 177 listUsers = do
 178     dbpath <- ask
 179     liftIO $ (unpathifyName <$>) . filter ((==3).length) <$>
 180         getDirectoryContents (dbpath++[pathSeparator]++"users")
 181
 182 recordPath :: Record -> DBM FilePath
 183 recordPath rec =
 184     (++ (pathSeparator : recordPath' rec)) <$> ask
 185     where
 186         recordPath' (RecPasswordLegacy name) = userDir name ++ "passwd"
 187         recordPath' (RecPasswordArgon2 name) = userDir name ++ "passwd_argon2"
 188         recordPath' (RecEmail name) = userDir name ++ "email"
 189         recordPath' (RecUserInfo name) = userDir name ++ "info"
 190         recordPath' (RecUserInfoLog name) = userDir name ++ "log"
 191         recordPath' (RecLock ls) = locksDir ++ show ls
 192         recordPath' (RecNote (NoteInfo name _  alock)) =
 193             userDir name ++ "notes" ++ [pathSeparator] ++ alockFN alock
 194         recordPath' (RecRetiredLocks name) = userDir name ++ "retired"
 195         recordPath' RecLockHashes = "lockHashes"
 196         recordPath' RecServerInfo = "serverInfo"
 197         recordPath' RecServerEmail = "serverEmail"
 198         recordPath' RecPublicKey = "publicKey"
 199         recordPath' RecSecretKey = "secretKey"
 200
 201         userDir name = "users" ++ [pathSeparator] ++ pathifyName name ++ [pathSeparator]
 202         alockFN (ActiveLock name idx) = pathifyName name ++":"++ show idx
 203         locksDir = "locks"++[pathSeparator]
 204
 205 pathifyName = winSux . dummyPunctuation
 206
 207 -- | Hilariously, "CON", "PRN", "AUX", and "NUL" are reserved on DOS, and
 208 -- Windows apparently crashes rather than write a directory with that name!
 209 winSux name = if (toUpper <$> name) `elem` ["CON","PRN", "AUX","NUL"]
 210     then '_':name
 211     else name
 212
 213 -- | Dummy out characters which are disallowed on unix or dos.
 214 -- We use lowercase characters as dummies.
 215 -- To avoid collisions on case-insensitive filesystems, we use '_' as an
 216 -- escape character.
 217 dummyPunctuation = concatMap $ \c ->
 218     maybe [c] (('_':) . pure) (lookup c pathifyAssocs)
 219 unpathifyName = concatMap $ \c -> case c of
 220         '_' -> ""
 221         _   -> pure $ fromMaybe c (lookup c $ swap <$> pathifyAssocs)
 222 pathifyAssocs =
 223     [ ('/','s')
 224     , ('.','d')
 225     , ('\\','b')
 226     , ('<','l')
 227     , ('>','g')
 228     , (':','c')
 229     , ('|','p')
 230     , ('?','q')
 231     , ('*','a')
 232     , ('+','t')
 233     , (',','m')
 234     , (';','i')
 235     , ('=','e')
 236     , ('[','k')
 237     , (']','j')
 238     , ('_','u')
 239     ]