git.iko.soy/servant-reflex
on master help sign in
Update BaseUrl to accomodate unspecified url
d455e5aGreg Hale
src/Servant/Common/BaseUrl.hs+46−35
compare with master
unifiedsplit
@@ -1,21 +1,25 @@
1−{-# LANGUAGE DeriveDataTypeable #-}
1+{-# LANGUAGE DeriveDataTypeable #-}
2−{-# LANGUAGE DeriveGeneric #-}
2+{-# LANGUAGE DeriveGeneric #-}
3−{-# LANGUAGE ViewPatterns #-}
3+{-# LANGUAGE ViewPatterns #-}
4+{-# LANGUAGE RankNTypes #-}
5+{-# LANGUAGE ScopedTypeVariables #-}
4module Servant.Common.BaseUrl (
6module Servant.Common.BaseUrl (
5 -- * types
7 -- * types
6 BaseUrl (..)
8 BaseUrl (..)
7− , InvalidBaseUrlException
8 , Scheme (..)
9 , Scheme (..)
9 -- * functions
10 -- * functions
10− , parseBaseUrl
11+ , baseUrlWidget
11 , showBaseUrl
12 , showBaseUrl
12) where
13) where
13
14
14import Control.Monad.Catch (Exception, MonadThrow, throwM)
15import Control.Monad.Catch (Exception, MonadThrow, throwM)
15import Data.List
16import Data.List
17+import Data.Monoid
16import Data.Typeable
18import Data.Typeable
17import GHC.Generics
19import GHC.Generics
18import Network.URI hiding (path)
20import Network.URI hiding (path)
21+import Reflex
22+import Reflex.Dom
19import Safe
23import Safe
20import Text.Read
24import Text.Read
21
25
@@ -23,25 +27,26 @@ import Text.Read
23data Scheme =
27data Scheme =
24 Http -- ^ http://
28 Http -- ^ http://
25 | Https -- ^ https://
29 | Https -- ^ https://
26− deriving (Show, Eq, Ord, Generic)
30+ deriving (Show, Read, Eq, Ord, Generic)
27
31
28-- | Simple data type to represent the target of HTTP requests
32-- | Simple data type to represent the target of HTTP requests
29-- for servant's automatically-generated clients.
33-- for servant's automatically-generated clients.
30−data BaseUrl = BaseUrl
34+data BaseUrl = BaseFullUrl Scheme String Int String
31− { baseUrlScheme :: Scheme -- ^ URI scheme to use
35+ | BasePath String
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)
36+ deriving (Ord, Read, Show, Generic)
37+
36
38
37instance Eq BaseUrl where
39instance Eq BaseUrl where
40+ BasePath s == BasePath s' = s == s'
38− BaseUrl a b c path == BaseUrl a' b' c' path'
41+ BaseFullUrl a b c path == BaseFullUrl a' b' c' path'
39 = a == a' && b == b' && c == c' && s path == s path'
42 = a == a' && b == b' && c == c' && s path == s path'
40 where s ('/':x) = x
43 where s ('/':x) = x
41 s x = x
44 s x = x
45+ _ == _ = False
42
46
43showBaseUrl :: BaseUrl -> String
47showBaseUrl :: BaseUrl -> String
48+showBaseUrl (BasePath s) = s
44−showBaseUrl (BaseUrl urlscheme host port path) =
49+showBaseUrl (BaseFullUrl urlscheme host port path) =
45 schemeString ++ "//" ++ host ++ (portString </> path)
50 schemeString ++ "//" ++ host ++ (portString </> path)
46 where
51 where
47 a </> b = if "/" `isPrefixOf` b || null b then a ++ b else a ++ '/':b
52 a </> b = if "/" `isPrefixOf` b || null b then a ++ b else a ++ '/':b
@@ -53,25 +58,31 @@ showBaseUrl (BaseUrl urlscheme host port path) =
53 (Https, 443) -> ""
58 (Https, 443) -> ""
54 _ -> ":" ++ show port
59 _ -> ":" ++ show port
55
60
56−data InvalidBaseUrlException = InvalidBaseUrlException String deriving (Show, Typeable)
61+baseUrlWidget :: forall t m .MonadWidget t m => m (Dynamic t BaseUrl)
57−instance Exception InvalidBaseUrlException
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
58
84
59−parseBaseUrl :: MonadThrow m => String -> m BaseUrl
85+apDyn :: MonadWidget t m => m (Dynamic t (a -> b)) -> Dynamic t a -> m (Dynamic t b)
60−parseBaseUrl s = case parseURI (removeTrailingSlash s) of
86+apDyn f' a = do
61− -- This is a rather hacky implementation and should be replaced with something
87+ f <- f'
62− -- implemented in attoparsec (which is already a dependency anyhow (via aeson)).
88+ combineDyn ($) f a
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