115 lines
3.1 KiB
Haskell
115 lines
3.1 KiB
Haskell
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
|
|
module Yesod.Core.Instances
|
|
(
|
|
) where
|
|
|
|
import Prelude (errorWithoutStackTrace)
|
|
import ClassyPrelude.Yesod
|
|
|
|
import Utils (assertM')
|
|
import Control.Lens
|
|
|
|
import Data.ByteString.Builder (toLazyByteString)
|
|
|
|
import Data.Aeson
|
|
import Data.Aeson.TH
|
|
import Data.Aeson.Types
|
|
|
|
import Control.Monad.Fix
|
|
import Control.Monad.Except (MonadError(..))
|
|
import Data.Functor.Extend
|
|
|
|
import Data.Binary (Binary)
|
|
import qualified Data.Binary as Binary
|
|
|
|
import Control.Monad.Fail
|
|
|
|
import Utils.PathPiece (camelToPathPiece)
|
|
|
|
import Network.HTTP.Types.Method.Instances ()
|
|
|
|
|
|
routeFromPathPiece :: ParseRoute site => Text -> Maybe (Route site)
|
|
routeFromPathPiece
|
|
= parseRoute
|
|
. over (_2.traverse._2) (fromMaybe "")
|
|
. over _2 queryToQueryText
|
|
. decodePath
|
|
. encodeUtf8
|
|
|
|
routeToPathPiece :: RenderRoute site => Route site -> Text
|
|
routeToPathPiece
|
|
= pack
|
|
. ("/" </>)
|
|
. unpack
|
|
. decodeUtf8
|
|
. toLazyByteString
|
|
. uncurry encodePath
|
|
. over _2 queryTextToQuery
|
|
. over (_2.traverse._2) (assertM' $ not . null)
|
|
. renderRoute
|
|
|
|
|
|
instance (RenderRoute site, ParseRoute site) => PathPiece (Route site) where
|
|
fromPathPiece = routeFromPathPiece
|
|
toPathPiece = routeToPathPiece
|
|
|
|
instance ParseRoute site => FromJSON (Route site) where
|
|
parseJSON = withText "Route" $ maybe (fail "Could not parse route") return . routeFromPathPiece
|
|
|
|
instance RenderRoute site => ToJSON (Route site) where
|
|
toJSON = String . routeToPathPiece
|
|
|
|
instance ParseRoute site => FromJSONKey (Route site) where
|
|
fromJSONKey = FromJSONKeyTextParser $ maybe (fail "Coulde not parse route") return . routeFromPathPiece
|
|
|
|
instance RenderRoute site => ToJSONKey (Route site) where
|
|
toJSONKey = toJSONKeyText routeToPathPiece
|
|
|
|
instance (RenderRoute site, ParseRoute site) => Binary (Route site) where
|
|
put = Binary.put . toPathPiece
|
|
get = Binary.get >>= maybe (fail "Could not parse route") return . fromPathPiece
|
|
|
|
instance RenderRoute site => Hashable (Route site) where
|
|
hashWithSalt s = hashWithSalt s . routeToPathPiece
|
|
|
|
|
|
instance Monad FormResult where
|
|
(FormSuccess a) >>= f = f a
|
|
FormMissing >>= _ = FormMissing
|
|
(FormFailure errs) >>= _ = FormFailure errs
|
|
|
|
instance MonadFail FormResult where
|
|
fail _ = FormMissing
|
|
|
|
instance MonadError [Text] FormResult where
|
|
throwError = FormFailure
|
|
|
|
catchError a@(FormSuccess _) _ = a
|
|
catchError FormMissing _ = FormMissing
|
|
catchError (FormFailure errs) h = h errs
|
|
|
|
instance MonadPlus FormResult
|
|
|
|
instance MonadFix FormResult where
|
|
mfix f = let a = f (unSuccess a) in a
|
|
where unSuccess (FormSuccess x) = x
|
|
unSuccess FormMissing = errorWithoutStackTrace "mfix FormResult: FormMissing"
|
|
unSuccess (FormFailure _) = errorWithoutStackTrace "mfix FormResult: FormFailure"
|
|
|
|
instance Extend FormResult where
|
|
duplicated (FormSuccess x) = FormSuccess $ FormSuccess x
|
|
duplicated FormMissing = FormMissing
|
|
duplicated (FormFailure errs) = FormFailure errs
|
|
|
|
|
|
deriveJSON defaultOptions
|
|
{ constructorTagModifier = camelToPathPiece
|
|
, sumEncoding = ObjectWithSingleField
|
|
} ''ErrorResponse
|
|
|
|
deriving instance Ord ErrorResponse
|
|
deriving instance Read ErrorResponse
|
|
instance Hashable ErrorResponse
|