module Mig.Core.Class.Url (
Url (..),
UrlOf,
renderUrl,
ToUrl (..),
) where
import Data.Aeson (ToJSON (..))
import Data.Bifunctor
import Data.Kind
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Maybe
import Data.Proxy
import Data.String
import Data.Text (Text)
import Data.Text qualified as Text
import GHC.TypeLits
import Mig.Core.Api (Path (..), PathItem (..), flatApi, fromFlatApi)
import Mig.Core.Class.Route (Route (..))
import Mig.Core.Server (Server (..), getServerPaths)
import Mig.Core.Types.Info (RouteInfo, routeHasCapture, routeHasOptionalQuery, routeHasQuery, routeHasQueryFlag)
import Mig.Core.Types.Pair
import Mig.Core.Types.Route
import Safe (headMay)
import Web.HttpApiData
data Url = Url
{ Url -> Path
path :: Path
, Url -> [(Text, Text)]
queries :: [(Text, Text)]
, Url -> Map Text Text
captures :: Map Text Text
}
instance ToJSON Url where
toJSON :: Url -> Value
toJSON = forall a. ToJSON a => a -> Value
toJSON forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => Url -> a
renderUrl @Text
renderUrl :: (IsString a) => Url -> a
renderUrl :: forall a. IsString a => Url -> a
renderUrl Url
url =
forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ Text -> String
Text.unpack forall a b. (a -> b) -> a -> b
$ Text -> Text
appendQuery forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => a -> a -> a
mappend Text
"/" forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
Text.intercalate Text
"/" forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PathItem -> Text
fromPathItem Url
url.path.unPath
where
fromPathItem :: PathItem -> Text
fromPathItem :: PathItem -> Text
fromPathItem = \case
StaticPath Text
text -> Text
text
CapturePath Text
name -> forall a. a -> Maybe a -> a
fromMaybe (Text
"{" forall a. Semigroup a => a -> a -> a
<> Text
name forall a. Semigroup a => a -> a -> a
<> Text
"}") forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
name Url
url.captures
appendQuery :: Text -> Text
appendQuery = case Url
url.queries of
[] -> forall a. a -> a
id
[(Text, Text)]
_ -> \Text
res -> forall a. Monoid a => [a] -> a
mconcat [Text
res, Text
"?", Text
query]
query :: Text
query = Text -> [Text] -> Text
Text.intercalate Text
"&" forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Text
name, Text
val) -> forall a. Monoid a => [a] -> a
mconcat [Text
name, Text
"=", Text
val]) Url
url.queries
type family UrlOf a :: Type where
UrlOf (Send method m a) = Url
UrlOf (Query name value -> b) = (Query name value -> UrlOf b)
UrlOf (Optional name value -> b) = (Optional name value -> UrlOf b)
UrlOf (Capture name value -> b) = (Capture name value -> UrlOf b)
UrlOf (QueryFlag name -> b) = (QueryFlag name -> UrlOf b)
UrlOf (Header name value -> b) = UrlOf b
UrlOf (OptionalHeader name value -> b) = UrlOf b
UrlOf (Body media value -> b) = UrlOf b
UrlOf (Cookie value -> b) = UrlOf b
UrlOf (PathInfo -> b) = UrlOf b
UrlOf (FullPathInfo -> b) = UrlOf b
UrlOf (RawRequest -> b) = UrlOf b
UrlOf (IsSecure -> b) = UrlOf b
UrlOf (a, b) = (UrlOf a, UrlOf b)
UrlOf (a, b, c) = (UrlOf a, UrlOf b, UrlOf c)
UrlOf (a, b, c, d) = (UrlOf a, UrlOf b, UrlOf c, UrlOf d)
UrlOf (a, b, c, d, e) = (UrlOf a, UrlOf b, UrlOf c, UrlOf d, UrlOf e)
UrlOf (a, b, c, d, e, f) = (UrlOf a, UrlOf b, UrlOf c, UrlOf d, UrlOf e, UrlOf f)
UrlOf (a :| b) = UrlOf a :| UrlOf b
class ToUrl a where
toUrl :: Server m -> a
mapUrl :: (Url -> Url) -> a -> a
urlArity :: Int
instance (ToUrl a, ToUrl b) => ToUrl (a :| b) where
toUrl :: forall (m :: * -> *). Server m -> a :| b
toUrl Server m
api = a
a forall a b. a -> b -> a :| b
:| b
b
where
(a
a, b
b) = forall a (m :: * -> *). ToUrl a => Server m -> a
toUrl Server m
api
mapUrl :: (Url -> Url) -> (a :| b) -> a :| b
mapUrl Url -> Url
f (a
a :| b
b) = (forall a. ToUrl a => (Url -> Url) -> a -> a
mapUrl Url -> Url
f a
a forall a b. a -> b -> a :| b
:| forall a. ToUrl a => (Url -> Url) -> a -> a
mapUrl Url -> Url
f b
b)
urlArity :: Int
urlArity = forall a. ToUrl a => Int
urlArity @(a, b)
instance (ToUrl a, ToUrl b) => ToUrl (a, b) where
toUrl :: forall (m :: * -> *). Server m -> (a, b)
toUrl (Server Api (Route m)
api) = (forall a (m :: * -> *). ToUrl a => Server m -> a
toUrl (forall (m :: * -> *). Api (Route m) -> Server m
Server Api (Route m)
apiA), forall a (m :: * -> *). ToUrl a => Server m -> a
toUrl (forall (m :: * -> *). Api (Route m) -> Server m
Server Api (Route m)
apiB))
where
(Api (Route m)
apiA, Api (Route m)
apiB) = forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap forall a. [(Path, a)] -> Api a
fromFlatApi forall a. [(Path, a)] -> Api a
fromFlatApi forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> ([a], [a])
Prelude.splitAt (forall a. ToUrl a => Int
urlArity @a) (forall a. Api a -> [(Path, a)]
flatApi Api (Route m)
api)
mapUrl :: (Url -> Url) -> (a, b) -> (a, b)
mapUrl Url -> Url
f (a
a, b
b) = (forall a. ToUrl a => (Url -> Url) -> a -> a
mapUrl Url -> Url
f a
a, forall a. ToUrl a => (Url -> Url) -> a -> a
mapUrl Url -> Url
f b
b)
urlArity :: Int
urlArity = forall a. ToUrl a => Int
urlArity @a forall a. Num a => a -> a -> a
+ forall a. ToUrl a => Int
urlArity @b
instance (ToUrl a, ToUrl b, ToUrl c) => ToUrl (a, b, c) where
toUrl :: forall (m :: * -> *). Server m -> (a, b, c)
toUrl Server m
server = forall {a} {b} {c}. (a, (b, c)) -> (a, b, c)
fromPair forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *). ToUrl a => Server m -> a
toUrl @(a, (b, c)) Server m
server
where
fromPair :: (a, (b, c)) -> (a, b, c)
fromPair (a
a, (b
b, c
c)) = (a
a, b
b, c
c)
mapUrl :: (Url -> Url) -> (a, b, c) -> (a, b, c)
mapUrl Url -> Url
f (a
a, b
b, c
c) = (forall a. ToUrl a => (Url -> Url) -> a -> a
mapUrl Url -> Url
f a
a, forall a. ToUrl a => (Url -> Url) -> a -> a
mapUrl Url -> Url
f b
b, forall a. ToUrl a => (Url -> Url) -> a -> a
mapUrl Url -> Url
f c
c)
urlArity :: Int
urlArity = forall a. ToUrl a => Int
urlArity @a forall a. Num a => a -> a -> a
+ forall a. ToUrl a => Int
urlArity @b forall a. Num a => a -> a -> a
+ forall a. ToUrl a => Int
urlArity @c
instance (ToUrl a, ToUrl b, ToUrl c, ToUrl d) => ToUrl (a, b, c, d) where
toUrl :: forall (m :: * -> *). Server m -> (a, b, c, d)
toUrl Server m
server = forall {a} {b} {c} {d}. (a, (b, c, d)) -> (a, b, c, d)
fromPair forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *). ToUrl a => Server m -> a
toUrl @(a, (b, c, d)) Server m
server
where
fromPair :: (a, (b, c, d)) -> (a, b, c, d)
fromPair (a
a, (b
b, c
c, d
d)) = (a
a, b
b, c
c, d
d)
mapUrl :: (Url -> Url) -> (a, b, c, d) -> (a, b, c, d)
mapUrl Url -> Url
f (a
a, b
b, c
c, d
d) = (forall a. ToUrl a => (Url -> Url) -> a -> a
mapUrl Url -> Url
f a
a, forall a. ToUrl a => (Url -> Url) -> a -> a
mapUrl Url -> Url
f b
b, forall a. ToUrl a => (Url -> Url) -> a -> a
mapUrl Url -> Url
f c
c, forall a. ToUrl a => (Url -> Url) -> a -> a
mapUrl Url -> Url
f d
d)
urlArity :: Int
urlArity = forall a. ToUrl a => Int
urlArity @a forall a. Num a => a -> a -> a
+ forall a. ToUrl a => Int
urlArity @b forall a. Num a => a -> a -> a
+ forall a. ToUrl a => Int
urlArity @c forall a. Num a => a -> a -> a
+ forall a. ToUrl a => Int
urlArity @d
instance ToUrl Url where
toUrl :: forall (m :: * -> *). Server m -> Url
toUrl Server m
server = case forall (m :: * -> *). Server m -> [Path]
getServerPaths Server m
server of
Path
url : [Path]
_ -> Path -> [(Text, Text)] -> Map Text Text -> Url
Url Path
url [] forall a. Monoid a => a
mempty
[Path]
_ -> Path -> [(Text, Text)] -> Map Text Text -> Url
Url forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty
mapUrl :: (Url -> Url) -> Url -> Url
mapUrl Url -> Url
f Url
a = Url -> Url
f Url
a
urlArity :: Int
urlArity = Int
1
instance (KnownSymbol sym, ToHttpApiData a, ToUrl b) => ToUrl (Query sym a -> b) where
toUrl :: forall (m :: * -> *). Server m -> Query sym a -> b
toUrl Server m
server = \(Query a
val) ->
forall a. Bool -> String -> a -> a
whenOrError (forall (m :: * -> *). Text -> Server m -> Bool
hasQuery (forall (sym :: Symbol) a. (KnownSymbol sym, IsString a) => a
getName @sym) Server m
server) String
noQuery forall a b. (a -> b) -> a -> b
$
forall a. ToUrl a => (Url -> Url) -> a -> a
mapUrl (Text -> Text -> Url -> Url
insertQuery (forall (sym :: Symbol) a. (KnownSymbol sym, IsString a) => a
getName @sym) (forall a. ToHttpApiData a => a -> Text
toUrlPiece a
val)) (forall a (m :: * -> *). ToUrl a => Server m -> a
toUrl @b Server m
server)
where
noQuery :: String
noQuery = forall (m :: * -> *). String -> Server m -> String
noInputMessage (String
"query with name: " forall a. Semigroup a => a -> a -> a
<> forall (sym :: Symbol) a. (KnownSymbol sym, IsString a) => a
getName @sym) Server m
server
mapUrl :: (Url -> Url) -> (Query sym a -> b) -> Query sym a -> b
mapUrl Url -> Url
f Query sym a -> b
a = \Query sym a
query -> forall a. ToUrl a => (Url -> Url) -> a -> a
mapUrl Url -> Url
f (Query sym a -> b
a Query sym a
query)
urlArity :: Int
urlArity = forall a. ToUrl a => Int
urlArity @b
insertQuery :: Text -> Text -> Url -> Url
insertQuery :: Text -> Text -> Url -> Url
insertQuery Text
name Text
val Url
url = Url
url{$sel:queries:Url :: [(Text, Text)]
queries = (Text
name, Text
val) forall a. a -> [a] -> [a]
: Url
url.queries}
hasQuery :: Text -> Server m -> Bool
hasQuery :: forall (m :: * -> *). Text -> Server m -> Bool
hasQuery Text
name = forall (m :: * -> *). (RouteInfo -> Bool) -> Server m -> Bool
hasInput (Text -> RouteInfo -> Bool
routeHasQuery Text
name)
instance (KnownSymbol sym, ToHttpApiData a, ToUrl b) => ToUrl (Optional sym a -> b) where
toUrl :: forall (m :: * -> *). Server m -> Optional sym a -> b
toUrl Server m
server = \(Optional Maybe a
mVal) ->
forall a. Bool -> String -> a -> a
whenOrError (forall (m :: * -> *). Text -> Server m -> Bool
hasOptionalQuery (forall (sym :: Symbol) a. (KnownSymbol sym, IsString a) => a
getName @sym) Server m
server) String
noOptionalQuery forall a b. (a -> b) -> a -> b
$
forall a. ToUrl a => (Url -> Url) -> a -> a
mapUrl (forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (Text -> Text -> Url -> Url
insertQuery (forall (sym :: Symbol) a. (KnownSymbol sym, IsString a) => a
getName @sym) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToHttpApiData a => a -> Text
toUrlPiece) Maybe a
mVal) (forall a (m :: * -> *). ToUrl a => Server m -> a
toUrl @b Server m
server)
where
noOptionalQuery :: String
noOptionalQuery = forall (m :: * -> *). String -> Server m -> String
noInputMessage (String
"optional query with name: " forall a. Semigroup a => a -> a -> a
<> forall (sym :: Symbol) a. (KnownSymbol sym, IsString a) => a
getName @sym) Server m
server
mapUrl :: (Url -> Url) -> (Optional sym a -> b) -> Optional sym a -> b
mapUrl Url -> Url
f Optional sym a -> b
a = \Optional sym a
query -> forall a. ToUrl a => (Url -> Url) -> a -> a
mapUrl Url -> Url
f (Optional sym a -> b
a Optional sym a
query)
urlArity :: Int
urlArity = forall a. ToUrl a => Int
urlArity @b
hasOptionalQuery :: Text -> Server m -> Bool
hasOptionalQuery :: forall (m :: * -> *). Text -> Server m -> Bool
hasOptionalQuery Text
name = forall (m :: * -> *). (RouteInfo -> Bool) -> Server m -> Bool
hasInput (Text -> RouteInfo -> Bool
routeHasOptionalQuery Text
name)
instance (KnownSymbol sym, ToUrl b) => ToUrl (QueryFlag sym -> b) where
toUrl :: forall (m :: * -> *). Server m -> QueryFlag sym -> b
toUrl Server m
server = \(QueryFlag Bool
val) ->
forall a. Bool -> String -> a -> a
whenOrError (forall (m :: * -> *). Text -> Server m -> Bool
hasQueryFlag (forall (sym :: Symbol) a. (KnownSymbol sym, IsString a) => a
getName @sym) Server m
server) String
noQueryFlag forall a b. (a -> b) -> a -> b
$
forall a. ToUrl a => (Url -> Url) -> a -> a
mapUrl (Text -> Text -> Url -> Url
insertQuery (forall (sym :: Symbol) a. (KnownSymbol sym, IsString a) => a
getName @sym) (forall a. ToHttpApiData a => a -> Text
toUrlPiece Bool
val)) (forall a (m :: * -> *). ToUrl a => Server m -> a
toUrl @b Server m
server)
where
noQueryFlag :: String
noQueryFlag = forall (m :: * -> *). String -> Server m -> String
noInputMessage (String
"query flag with name: " forall a. Semigroup a => a -> a -> a
<> forall (sym :: Symbol) a. (KnownSymbol sym, IsString a) => a
getName @sym) Server m
server
mapUrl :: (Url -> Url) -> (QueryFlag sym -> b) -> QueryFlag sym -> b
mapUrl Url -> Url
f QueryFlag sym -> b
a = \QueryFlag sym
query -> forall a. ToUrl a => (Url -> Url) -> a -> a
mapUrl Url -> Url
f (QueryFlag sym -> b
a QueryFlag sym
query)
urlArity :: Int
urlArity = forall a. ToUrl a => Int
urlArity @b
hasQueryFlag :: Text -> Server m -> Bool
hasQueryFlag :: forall (m :: * -> *). Text -> Server m -> Bool
hasQueryFlag Text
name = forall (m :: * -> *). (RouteInfo -> Bool) -> Server m -> Bool
hasInput (Text -> RouteInfo -> Bool
routeHasQueryFlag Text
name)
instance (KnownSymbol sym, ToHttpApiData a, ToUrl b) => ToUrl (Capture sym a -> b) where
toUrl :: forall (m :: * -> *). Server m -> Capture sym a -> b
toUrl Server m
server = \(Capture a
val) ->
forall a. Bool -> String -> a -> a
whenOrError (forall (m :: * -> *). Text -> Server m -> Bool
hasCapture (forall (sym :: Symbol) a. (KnownSymbol sym, IsString a) => a
getName @sym) Server m
server) String
noCapture forall a b. (a -> b) -> a -> b
$
forall a. ToUrl a => (Url -> Url) -> a -> a
mapUrl (Text -> Text -> Url -> Url
insertCapture (forall (sym :: Symbol) a. (KnownSymbol sym, IsString a) => a
getName @sym) (forall a. ToHttpApiData a => a -> Text
toUrlPiece a
val)) (forall a (m :: * -> *). ToUrl a => Server m -> a
toUrl @b Server m
server)
where
noCapture :: String
noCapture = forall (m :: * -> *). String -> Server m -> String
noInputMessage (String
"Capture with name: " forall a. Semigroup a => a -> a -> a
<> forall (sym :: Symbol) a. (KnownSymbol sym, IsString a) => a
getName @sym) Server m
server
mapUrl :: (Url -> Url) -> (Capture sym a -> b) -> Capture sym a -> b
mapUrl Url -> Url
f Capture sym a -> b
a = \Capture sym a
capture -> forall a. ToUrl a => (Url -> Url) -> a -> a
mapUrl Url -> Url
f (Capture sym a -> b
a Capture sym a
capture)
urlArity :: Int
urlArity = forall a. ToUrl a => Int
urlArity @b
insertCapture :: Text -> Text -> Url -> Url
insertCapture :: Text -> Text -> Url -> Url
insertCapture Text
name Text
val Url
url = Url
url{$sel:captures:Url :: Map Text Text
captures = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
name Text
val Url
url.captures}
hasCapture :: Text -> Server m -> Bool
hasCapture :: forall (m :: * -> *). Text -> Server m -> Bool
hasCapture Text
name = forall (m :: * -> *). (RouteInfo -> Bool) -> Server m -> Bool
hasInput (Text -> RouteInfo -> Bool
routeHasCapture Text
name)
getName :: forall sym a. (KnownSymbol sym, IsString a) => a
getName :: forall (sym :: Symbol) a. (KnownSymbol sym, IsString a) => a
getName = forall a. IsString a => String -> a
fromString (forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
Proxy @sym))
hasInput :: (RouteInfo -> Bool) -> Server m -> Bool
hasInput :: forall (m :: * -> *). (RouteInfo -> Bool) -> Server m -> Bool
hasInput RouteInfo -> Bool
check (Server Api (Route m)
api) =
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (RouteInfo -> Bool
check forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.info) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Maybe a
headMay forall a b. (a -> b) -> a -> b
$ forall a. Api a -> [(Path, a)]
flatApi Api (Route m)
api
noInputMessage :: String -> Server m -> String
noInputMessage :: forall (m :: * -> *). String -> Server m -> String
noInputMessage String
item (Server Api (Route m)
api) =
[String] -> String
unlines
[ [String] -> String
unwords [String
"Server has no", String
item, String
"at route", String
route]
, String
"Check the order of routes on the left side of toUrl expression"
]
where
route :: String
route = forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"unknown" (Text -> String
Text.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToHttpApiData a => a -> Text
toUrlPiece forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Maybe a
headMay (forall a. Api a -> [(Path, a)]
flatApi Api (Route m)
api)
whenOrError :: Bool -> String -> a -> a
whenOrError :: forall a. Bool -> String -> a -> a
whenOrError Bool
cond String
message a
a
| Bool
cond = a
a
| Bool
otherwise = forall a. HasCallStack => String -> a
error String
message