Cache.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 {-# LANGUAGE LambdaCase #-}
  12
  13 module Cache where
  14
  15 import           Control.Applicative
  16 import           Control.Concurrent
  17 import           Control.Concurrent.STM
  18 import           Control.Monad
  19 import           Control.Monad.Catch
  20 import           Control.Monad.Trans.Reader
  21 import           Data.Binary
  22 import qualified Data.ByteString            as BS
  23 import qualified Data.ByteString.Lazy       as BL
  24 import           Data.Maybe
  25 import           Network.Simple.TCP         (connect, recv, send)
  26 import           System.Directory
  27 import           System.FilePath
  28 import           System.IO
  29
  30 import           Database
  31 import           Metagame
  32 import           Mundanities
  33 import           Protocol
  34 import           ServerAddr
  35
  36 data FetchedRecord = FetchedRecord {fresh :: Bool, fetchError :: Maybe String, fetchedRC :: Maybe RecordContents}
  37     deriving (Eq, Show)
  38
  39
  40 getRecordCached :: ServerAddr -> Maybe Auth -> Maybe (TVar Bool) -> Bool -> Record -> IO (TVar FetchedRecord)
  41 getRecordCached saddr _ _ _ _ | nullSaddr saddr = do
  42     newTVarIO (FetchedRecord True (Just "No server set.") Nothing)
  43 getRecordCached saddr auth mflag cOnly rec = do
  44     fromCache <- withCache saddr $ getRecord rec
  45     let fresh = isJust fromCache && invariantRecord rec
  46     tvar <- newTVarIO (FetchedRecord fresh Nothing fromCache)
  47     unless (cOnly || fresh) $ void $ forkIO $ getRecordFromServer fromCache tvar
  48     return tvar
  49     where
  50         getRecordFromServer fromCache tvar = do
  51             let action = case rec of
  52                     RecUserInfo name ->
  53                         let curVersion = (\(RCUserInfo (v,_)) -> v) <$> fromCache
  54                         in GetUserInfo name curVersion
  55                     _ -> askForRecord rec
  56             resp <- makeRequest saddr (ClientRequest
  57                     protocolVersion (if needsAuth action then auth else Nothing) action)
  58             case resp of
  59                 ServerError err -> tellRec $ FetchedRecord True (Just err) fromCache
  60                 ServerCodenameFree -> tellRec $ FetchedRecord True Nothing Nothing
  61                 ServerFresh -> tellRec $ FetchedRecord True Nothing fromCache
  62                 ServedUserInfoDeltas deltas -> do
  63                     let Just (RCUserInfo (v,info)) = fromCache
  64                     let rc = RCUserInfo (v+length deltas, applyDeltas info deltas)
  65                     withCache saddr $ putRecord rec rc
  66                     tellRec $ FetchedRecord True Nothing (Just rc)
  67                 _ -> do
  68                     let rc = rcOfServerResp resp
  69                     withCache saddr $ putRecord rec rc
  70                     tellRec $ FetchedRecord True Nothing (Just rc)
  71             where
  72                 tellRec fr = atomically $ do
  73                     writeTVar tvar fr
  74                     case mflag of {Just flag -> writeTVar flag True; _ -> return ()}
  75
  76 waitFetchedFresh :: TVar FetchedRecord -> IO ()
  77 waitFetchedFresh tvar = atomically $ readTVar tvar >>= check.fresh
  78
  79 makeRequest :: ServerAddr -> ClientRequest -> IO ServerResponse
  80 makeRequest saddr _ | nullSaddr saddr =
  81     return $ ServerError "No server set."
  82 makeRequest saddr@(ServerAddr host port) request =
  83     handle (return . ServerError . (show::SomeException -> String)) $ do
  84         connect host (show port) makeRequest'
  85             `catchIO` const (return $ ServerError $ "Cannot connect to "++saddrStr saddr++"!")
  86     where
  87         makeRequest' (sock,_) = do
  88             send sock . BL.toStrict $ encode request
  89             decode . BL.fromStrict <$> recvAll sock
  90         recvAll sock =
  91             recv sock 4096 >>= \case
  92                 Nothing -> return BS.empty
  93                 Just b  -> BS.append b <$> recvAll sock
  94
  95
  96 knownServers :: IO [ServerAddr]
  97 knownServers = ignoreIOErr $ do
  98     cachedir <- confFilePath "cache"
  99     saddrstrs <- getDirectoryContents cachedir >>= filterM (\dir ->
 100         doesFileExist $ cachedir++[pathSeparator]++dir++[pathSeparator]++"serverInfo")
 101     return $ mapMaybe strToSaddr saddrstrs
 102
 103 withCache :: ServerAddr -> DBM a -> IO a
 104 withCache saddr m = do
 105     cachedir <- (++pathSeparator : saddrPath saddr) <$> confFilePath "cache"
 106     runReaderT m cachedir