{- Copyright 2017 Joey Hess <id@joeyh.name>
 -
 - 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 }
