content: {-# OPTIONS_GHC -fno-warn-orphans #-}
  {-# LANGUAGE
      CPP
    , GeneralizedNewtypeDeriving
    , NoImplicitPrelude
    , RankNTypes
    #-}
  #if MIN_VERSION_base(4,9,0)
  {-# OPTIONS_GHC -Wno-redundant-constraints #-}
  #endif
  module Rest.Driver.Snap
    ( apiToHandler
    , apiToHandler'
    ) where
  
  import Prelude.Compat
  
  import Safe
  import Snap.Core
  import Snap.Util.FileServe (defaultMimeTypes)
  
  import qualified Data.ByteString.Char8 as Char8
  import qualified Data.ByteString.UTF8  as UTF8
  import qualified Data.CaseInsensitive  as CI
  import qualified Data.HashMap.Strict   as M
  import qualified Network.URI.Encode    as URI
  import qualified Snap.Core             as Snap
  
  import Rest.Api (Api)
  import Rest.Driver.Perform (Rest (..))
  import Rest.Driver.Types (Run)
  
  import qualified Rest.Driver.Types as Rest
  import qualified Rest.Run          as Rest
  
  newtype Snapped m a = Snapped { unSnapped :: m a }
    deriving (Applicative, Functor, Monad)
  
  apiToHandler :: (MonadSnap m, Rest m, Applicative m, Monad m) => Api m -> m ()
  apiToHandler = apiToHandler' id
  
  apiToHandler' :: (Applicative m, Monad m, MonadSnap n) => Run m n -> Api m -> n ()
  apiToHandler' run api = writeLBS =<< unSnapped (Rest.apiToHandler' (Snapped . run) api)
  
  instance (MonadSnap m) => Rest (Snapped m) where
    getHeader nm       = Snapped $ getsRequest (fmap UTF8.toString . Snap.getHeader (CI.mk . UTF8.fromString $ nm))
    getParameter  nm   = Snapped $ getsRequest (fmap UTF8.toString . (>>= headMay) . rqParam (UTF8.fromString nm))
    getBody            = Snapped $ readRequestBody (1 * 1024 * 1024)
    getMethod          = Snapped $ getsRequest (toRestMethod . rqMethod)
    getPaths           = Snapped $ getsRequest (map (UTF8.toString . URI.decodeByteString) . filter (not . Char8.null) . Char8.split '/' . rqPathInfo)
    lookupMimeType     = Snapped . return . fmap UTF8.toString . flip M.lookup defaultMimeTypes
    setHeader nm v     = Snapped $ modifyResponse (Snap.setHeader (CI.mk . UTF8.fromString $ nm) (UTF8.fromString v))
    setResponseCode cd = Snapped $ modifyResponse (Snap.setResponseCode cd)
  
  toRestMethod :: Snap.Method -> Maybe Rest.Method
  toRestMethod Snap.GET    = Just Rest.GET
  toRestMethod Snap.POST   = Just Rest.POST
  toRestMethod Snap.PUT    = Just Rest.PUT
  toRestMethod Snap.DELETE = Just Rest.DELETE
  toRestMethod _           = Nothing
  