content: {-# LANGUAGE
      DeriveDataTypeable
    , DeriveGeneric
    , LambdaCase
    , OverloadedStrings
    , ScopedTypeVariables
    #-}
  module Api.Test
    ( resource
    , WithText
    , Err (..)
    , Ok (..)
    ) where
  
  import Control.Monad.Except
  import Control.Monad.Reader
  import Data.Aeson
  import Data.ByteString.Lazy (ByteString)
  import Data.Data
  import Data.JSON.Schema
  import Data.Maybe
  import Data.Text (Text)
  import GHC.Generics
  import Generics.Generic.Aeson
  import Generics.XmlPickler
  import Safe
  import Text.XML.HXT.Arrow.Pickle
  
  import Rest
  import Rest.Dictionary
  import qualified Rest.Driver.Perform as Driver (accept)
  import qualified Rest.Resource       as R
  
  import ApiTypes
  import qualified Api.Test.Err2 as E2
  
  -- | User extends the root of the API with a reader containing the ways to identify a user in our URLs.
  -- Currently only by the user name.
  type WithText = ReaderT Text BlogApi
  
  data Err = Err deriving (Generic, Show, Typeable)
  instance ToJSON     Err where toJSON    = gtoJson
  instance FromJSON   Err where parseJSON = gparseJson
  instance JSONSchema Err where schema    = gSchema
  instance XmlPickler Err where xpickle   = gxpickle
  
  instance ToResponseCode Err where
    toResponseCode _ = 400
  
  data Ok = Ok deriving (Generic, Show, Typeable)
  instance XmlPickler Ok where xpickle = gxpickle
  instance ToJSON     Ok where toJSON    = gtoJson
  instance FromJSON   Ok where parseJSON = gparseJson
  instance JSONSchema Ok where schema    = gSchema
  
  resource :: Resource BlogApi WithText Text Void Void
  resource = mkResourceReader
    { R.name    = "test"
    , R.actions = [ ("noResponse"         , noResponse         )
                  , ("onlyError"          , onlyError          )
                  , ("differentFormats"   , differentFormats   )
                  , ("intersectedFormats" , intersectedFormats )
                  , ("intersectedFormats2", intersectedFormats2)
                  , ("rawXmlIO"           , rawXmlIO           )
                  , ("rawJsonIO"          , rawJsonIO          )
                  , ("rawJsonAndXmlI"     , rawJsonAndXmlI_    )
                  , ("rawJsonAndXmlO"     , rawJsonAndXmlO_    )
                  , ("noError"            , noError            )
                  , ("justStringO"        , justStringO        )
                  , ("preferJson"         , preferJson         )
                  , ("octetStreamOut"     , octetStreamOut     )
                  , ("onlyInput"          , onlyInput          )
                  ]
    }
  
  noResponse :: Handler WithText
  noResponse = mkConstHandler id $ return ()
  
  onlyError :: Handler WithText
  onlyError = mkConstHandler jsonE $
    throwError $ domainReason Err
  
  differentFormats :: Handler WithText
  differentFormats = mkInputHandler (jsonE . xmlO . stringI) $
    \case
      "error" -> throwError $ domainReason Err
      _       -> return Ok
  
  intersectedFormats :: Handler WithText
  intersectedFormats = mkInputHandler (jsonE . xmlO . jsonO . stringI) $
    \case
      "error" -> throwError $ domainReason Err
      _       -> return Ok
  
  intersectedFormats2 :: Handler WithText
  intersectedFormats2 = mkInputHandler (xmlE . xmlO . jsonO . stringI) $
    \case
      "error" -> throwError $ domainReason Err
      _       -> return Ok
  
  rawXmlIO :: Handler WithText
  rawXmlIO = mkIdHandler (rawXmlI . rawXmlO . xmlE) $ \s _ ->
    case s of
      "<error/>" -> throwError $ domainReason E2.Err
      _          -> return "<ok/>"
  
  rawJsonIO :: Handler WithText
  rawJsonIO = mkIdHandler (rawJsonI . rawJsonO . jsonE) $ \s _ ->
    case s of
      "\"error\"" -> throwError $ domainReason E2.Err
      _           -> return "\"ok\""
  
  rawJsonAndXmlI_ :: Handler WithText
  rawJsonAndXmlI_ = mkInputHandler (stringO . rawJsonAndXmlI) handler
    where
      handler :: Either Json Xml -> ExceptT Reason_ WithText String
      handler = return . \case
        Left (Json _) -> "json input"
        Right (Xml _) -> "xml input"
  
  rawJsonAndXmlO_ :: Handler WithText
  rawJsonAndXmlO_ = mkHandler (addHeader contentType . mkHeader accept . mkPar typeParam . rawJsonAndXmlO) handler
    where
      handler :: Env (Maybe String, Maybe String) (Maybe String) () -> ExceptT Reason_ WithText ByteString
      handler (Env (mContentType, mAccept) mType ()) = do
        let accs = Driver.accept mAccept mContentType mType
        if JsonFormat `elem` accs
          then return "\"json\""
          else if XmlFormat `elem` accs
            then return "<xml/>"
            else throwError . OutputError $ UnsupportedFormat "Only json and xml accept headers are allowed"
      contentType :: Header (Maybe String)
      contentType  = Header ["Content-Type"] (return . headMay . catMaybes)
      typeParam   :: Param (Maybe String)
      typeParam    = Param ["type"] (return . headMay . catMaybes)
      accept      :: Header (Maybe String)
      accept       = Header ["Accept"] (return . headMay . catMaybes)
  
  noError :: Handler WithText
  noError = mkConstHandler jsonO $ return Ok
  
  justStringO :: Handler WithText
  justStringO = mkConstHandler stringO $ return "Ok"
  
  preferJson :: Handler WithText
  preferJson = mkInputHandler (xmlJsonO . xmlJsonE . stringI) $
    \case
      "error" -> throwError $ domainReason Err
      _       -> return Ok
  
  octetStreamOut :: Handler WithText
  octetStreamOut = mkInputHandler (fileI . fileO . xmlJsonE) $
    \case
      "error" -> throwError $ domainReason Err
      _       -> return ("ok", "ok", False)
  
  onlyInput :: Handler WithText
  onlyInput = mkInputHandler jsonI $ \() -> throwError NotFound
  