@@ -1,21 +1,25 @@
1−{-# LANGUAGE DeriveDataTypeable #-}
2−{-# LANGUAGE DeriveGeneric #-}
3−{-# LANGUAGE ViewPatterns #-}
1+{-# LANGUAGE DeriveDataTypeable #-}
2+{-# LANGUAGE DeriveGeneric #-}
3+{-# LANGUAGE ViewPatterns #-}
4+{-# LANGUAGE RankNTypes #-}
5+{-# LANGUAGE ScopedTypeVariables #-}
46module Servant.Common.BaseUrl (
57 -- * types
68 BaseUrl (..)
7− , InvalidBaseUrlException
89 , Scheme (..)
910 -- * functions
10− , parseBaseUrl
11+ , baseUrlWidget
1112 , showBaseUrl
1213) where
1314
1415import Control.Monad.Catch (Exception, MonadThrow, throwM)
1516import Data.List
17+import Data.Monoid
1618import Data.Typeable
1719import GHC.Generics
1820import Network.URI hiding (path)
21+import Reflex
22+import Reflex.Dom
1923import Safe
2024import Text.Read
2125
@@ -23,25 +27,26 @@ import Text.Read
2327data Scheme =
2428 Http -- ^ http://
2529 | Https -- ^ https://
26− deriving (Show, Eq, Ord, Generic)
30+ deriving (Show, Read, Eq, Ord, Generic)
2731
2832-- | Simple data type to represent the target of HTTP requests
2933-- for servant's automatically-generated clients.
30−data BaseUrl = BaseUrl
31− { baseUrlScheme :: Scheme -- ^ URI scheme to use
32− , baseUrlHost :: String -- ^ host (eg "haskell.org")
33− , baseUrlPort :: Int -- ^ port (eg 80)
34− , baseUrlPath :: String -- ^ path (eg "/a/b/c")
35− } deriving (Show, Ord, Generic)
34+data BaseUrl = BaseFullUrl Scheme String Int String
35+ | BasePath String
36+ deriving (Ord, Read, Show, Generic)
37+
3638
3739instance Eq BaseUrl where
38− BaseUrl a b c path == BaseUrl a' b' c' path'
40+ BasePath s == BasePath s' = s == s'
41+ BaseFullUrl a b c path == BaseFullUrl a' b' c' path'
3942 = a == a' && b == b' && c == c' && s path == s path'
4043 where s ('/':x) = x
4144 s x = x
45+ _ == _ = False
4246
4347showBaseUrl :: BaseUrl -> String
44−showBaseUrl (BaseUrl urlscheme host port path) =
48+showBaseUrl (BasePath s) = s
49+showBaseUrl (BaseFullUrl urlscheme host port path) =
4550 schemeString ++ "//" ++ host ++ (portString </> path)
4651 where
4752 a </> b = if "/" `isPrefixOf` b || null b then a ++ b else a ++ '/':b
@@ -53,25 +58,31 @@ showBaseUrl (BaseUrl urlscheme host port path) =
5358 (Https, 443) -> ""
5459 _ -> ":" ++ show port
5560
56−data InvalidBaseUrlException = InvalidBaseUrlException String deriving (Show, Typeable)
57−instance Exception InvalidBaseUrlException
61+baseUrlWidget :: forall t m .MonadWidget t m => m (Dynamic t BaseUrl)
62+baseUrlWidget = elClass "div" "base-url" $ do
63+ urlWidget <- dropdown (0 :: Int) (constDyn $ 0 =: "BaseUrlFull" <> 1 =: "BasePath") def
64+ bUrlWidget <- forDyn (value urlWidget) $ \i -> case i of
65+ 0 -> fullUrlWidget
66+ 1 -> pathWidget
67+ _ -> error "Surprising value"
68+ joinDyn <$> widgetHold fullUrlWidget (updated bUrlWidget)
69+ where pathWidget :: m (Dynamic t BaseUrl)
70+ pathWidget = do
71+ text "Url base path"
72+ t <- textInput (def {_textInputConfig_attributes =
73+ constDyn ("placeholder" =: "/a/b")})
74+ mapDyn BasePath (value t)
75+ fullUrlWidget :: m (Dynamic t BaseUrl)
76+ fullUrlWidget = do
77+ schm <- dropdown Https (constDyn $ Https =: "https" <> Http =: "http") def
78+ srv <- textInput def {_textInputConfig_attributes = constDyn $ "placeholder" =: "example.com"}
79+ text ":"
80+ prt <- textInput def { _textInputConfig_attributes = constDyn $ "placeholder" =: "80"}
81+ port :: Dynamic t Int <- holdDyn 80 (fmapMaybe readMaybe $ updated (value prt))
82+ path <- textInput def { _textInputConfig_attributes = constDyn $ "placeholder" =: "a/b" }
83+ BaseFullUrl `mapDyn` value schm `apDyn` value srv `apDyn` port `apDyn` value path
5884
59−parseBaseUrl :: MonadThrow m => String -> m BaseUrl
60−parseBaseUrl s = case parseURI (removeTrailingSlash s) of
61− -- This is a rather hacky implementation and should be replaced with something
62− -- implemented in attoparsec (which is already a dependency anyhow (via aeson)).
63− Just (URI "http:" (Just (URIAuth "" host (':' : (readMaybe -> Just port)))) path "" "") ->
64− return (BaseUrl Http host port path)
65− Just (URI "http:" (Just (URIAuth "" host "")) path "" "") ->
66− return (BaseUrl Http host 80 path)
67− Just (URI "https:" (Just (URIAuth "" host (':' : (readMaybe -> Just port)))) path "" "") ->
68− return (BaseUrl Https host port path)
69− Just (URI "https:" (Just (URIAuth "" host "")) path "" "") ->
70− return (BaseUrl Https host 443 path)
71− _ -> if "://" `isInfixOf` s
72− then throwM (InvalidBaseUrlException $ "Invalid base URL: " ++ s)
73− else parseBaseUrl ("http://" ++ s)
74− where
75− removeTrailingSlash str = case lastMay str of
76− Just '/' -> init str
77− _ -> str
85+apDyn :: MonadWidget t m => m (Dynamic t (a -> b)) -> Dynamic t a -> m (Dynamic t b)
86+apDyn f' a = do
87+ f <- f'
88+ combineDyn ($) f a