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

-- | Url-template type.
data Url = Url
  { Url -> Path
path :: Path
  -- ^ relative path
  , Url -> [(Text, Text)]
queries :: [(Text, Text)]
  -- ^ queries in the URL
  , Url -> Map Text Text
captures :: Map Text Text
  -- ^ map of captures
  }

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

{-| Render URL to string-like value.

TODO: use Text.Builder
-}
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

-------------------------------------------------------------------------------------
-- render routes to safe URLs

-- | Converts route type to URL function
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

{-| Converts server to safe url. We can use it to generate
safe URL constructors to be used in HTML templates
An example of how we can create safe URL's. Note
that order of URL's should be the same as in server definition:

> type GreetingRoute = Get Html
> type BlogPostRoute = Optional "id" BlogPostId -> Get Html
> type ListPostsRoute = Get Html
>
> data Routes = Routes
>   { greeting :: GreetingRoute
>   , blogPost :: BlogPostRoute
>   , listPosts :: ListPostsRoute
>   }
>
> -- URLs
>
> data Urls = Urls
>   { greeting :: UrlOf GreetingRoute
>   , blogPost :: UrlOf BlogPostRoute
>   , listPosts :: UrlOf ListPostsRoute
>   }
>
> {\-| Site URL's
> URL's should be listed in the same order as they appear in the server
> -\}
> urls :: Urls
> urls = Urls{..}
>   where
>     greeting
>       :| blogPost
>       :| listPosts
>         toUrl (server undefined)
-}
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

-- query

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)

-- optional query

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)

-- query flag

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)

-- capture

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)

-------------------------------------------------------------------------------------
-- utils

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