{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Factis.Haskoon.RqAccessM
    (RqData(..), RqAccess(..), RqAccessM(..), runRqAccessM)
where

----------------------------------------
-- STDLIB
----------------------------------------
import Control.Monad (MonadPlus)
import Control.Monad.Reader (ReaderT(runReaderT),asks)

----------------------------------------
-- SITE-PACKAGES
----------------------------------------
import Safe (atMay)

----------------------------------------
-- LOCAL
----------------------------------------
import Factis.Haskoon.RqAccess (RqAccess(..))

data RqData = RqData { rqd_method :: String
                     , rqd_params :: [(String,String)]
                     , rqd_headers :: [(String,String)]
                     , rqd_repls :: [String]
                     , rqd_cookies :: [(String, String)]
                     }

type RqRead a = ReaderT RqData (Either String) a

newtype RqAccessM a = RqAccessM (RqRead a) deriving (Monad, MonadPlus)


instance RqAccess RqAccessM where
    param n = RqAccessM (readFromPairs rqd_params n "Parameter")
    repl i = RqAccessM (readFromRqData rqd_repls (flip atMay i) desc)
        where desc = "Replacement "++show i
    cookie n = RqAccessM (readFromPairs rqd_cookies n "Cookie")
    header n = RqAccessM (readFromPairs rqd_headers n "Header")
    checkMethod isMethOk =
        RqAccessM $
        do meth <- asks rqd_method
           if isMethOk meth
             then return meth
             else fail $ "Invalid request method `"++meth++"'."

readFromPairs :: (Eq a,Show a) => (RqData -> [(a,b)]) -> a -> String -> RqRead b
readFromPairs rqd_pairs key name = readFromRqData rqd_pairs findIn desc
    where findIn = lookup key
          desc = name ++ " `"++show key++"'"

readFromRqData :: (RqData -> a) -> (a -> Maybe b) -> String -> RqRead b
readFromRqData rqd_value findIn desc =
    do value <- asks rqd_value
       case findIn value of
         Nothing -> fail $ desc ++ " not found."
         Just v -> return v

runRqAccessM :: RqAccessM t -> RqData -> Either String t
runRqAccessM (RqAccessM r) d = runReaderT r d