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