{- Copyright 2017 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE OverloadedStrings, DeriveGeneric #-} module SessionID ( SessionID, mkSessionID, sessionLogFile, withSessionID, sessionIDUrl, ) where import JSON import System.FilePath import System.IO import System.Directory import Data.List import Data.UUID import Data.UUID.V4 import Network.URI import Control.Concurrent.STM import Control.Exception -- | A SessionID is the base name of the log file to use, -- and may not contain any path information. newtype SessionID = SessionID FilePath deriving (Show, Eq, Ord, Generic) -- | Custom JSON deserialization so we can check smart constructor -- to verify it's legal. instance FromJSON SessionID where parseJSON v = verify =<< genericParseJSON defaultOptions v where verify (SessionID unverified) = maybe (fail "illegal SessionID") return (mkSessionID unverified) instance ToJSON SessionID -- | Smart constructor that enforces legal SessionID contents. -- -- The passed String can either be the bare SessionID, or it can be an URL -- which ends with the SessionID. mkSessionID :: String -> Maybe SessionID mkSessionID s | "http" `isPrefixOf` s = Just $ SessionID $ takeFileName s | takeFileName s == s = Just $ SessionID s | otherwise = Nothing sessionLogFile :: FilePath -> SessionID -> FilePath sessionLogFile dir (SessionID f) = dir "debug-me." ++ f ++ ".log" -- | Allocate a new SessionID open a Handle to its log file. -- -- A UUID is used, to avoid ever generating a SessionID that has been used -- before. withSessionID :: FilePath -> ((TVar Handle, SessionID) -> IO a) -> IO a withSessionID dir a = do createDirectoryIfMissing False dir sid <- SessionID . toString <$> nextRandom let f = sessionLogFile dir sid -- File should not already exist, but just in case we get -- spectacularly unlucky (or the RNG is broken..), -- avoid overwriting a log, and try again. exists <- doesFileExist f if exists then withSessionID dir a else bracket (setup f) cleanup (go sid) where setup f = do h <- openFile f WriteMode hv <- newTVarIO h return hv cleanup hv = hClose =<< atomically (readTVar hv) go sid hv = a (hv, sid) sessionIDUrl :: SessionID -> URI -> URI sessionIDUrl (SessionID f) serverurl = serverurl { uriPath = "/" ++ f }