{-# LANGUAGE CPP #-}
module Freckle.App.Memcached.Servers
( MemcachedServers (..)
, defaultMemcachedServers
, emptyMemcachedServers
, readMemcachedServers
, toServerSpecs
) where
import Freckle.App.Prelude
import Control.Error.Util (note)
import qualified Data.Text as T
import qualified Database.Memcache.Client as Memcache
import Network.URI (URI (..), URIAuth (..), parseAbsoluteURI)
newtype MemcachedServers = MemcachedServers
{ MemcachedServers -> [MemcachedServer]
unMemcachedServers :: [MemcachedServer]
}
defaultMemcachedServers :: MemcachedServers
defaultMemcachedServers :: MemcachedServers
defaultMemcachedServers = [MemcachedServer] -> MemcachedServers
MemcachedServers [MemcachedServer
defaultMemcachedServer]
emptyMemcachedServers :: MemcachedServers
emptyMemcachedServers :: MemcachedServers
emptyMemcachedServers = [MemcachedServer] -> MemcachedServers
MemcachedServers []
readMemcachedServers :: String -> Either String MemcachedServers
readMemcachedServers :: String -> Either String MemcachedServers
readMemcachedServers =
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [MemcachedServer] -> MemcachedServers
MemcachedServers
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (String -> Either String MemcachedServer
readMemcachedServer forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
unpack)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
T.null)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
T.strip
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> [Text]
T.splitOn Text
","
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack
toServerSpecs :: MemcachedServers -> [Memcache.ServerSpec]
toServerSpecs :: MemcachedServers -> [ServerSpec]
toServerSpecs = forall a b. (a -> b) -> [a] -> [b]
map MemcachedServer -> ServerSpec
unMemcachedServer forall b c a. (b -> c) -> (a -> b) -> a -> c
. MemcachedServers -> [MemcachedServer]
unMemcachedServers
newtype MemcachedServer = MemcachedServer
{ MemcachedServer -> ServerSpec
unMemcachedServer :: Memcache.ServerSpec
}
defaultMemcachedServer :: MemcachedServer
defaultMemcachedServer :: MemcachedServer
defaultMemcachedServer = ServerSpec -> MemcachedServer
MemcachedServer forall a. Default a => a
Memcache.def
readMemcachedServer :: String -> Either String MemcachedServer
readMemcachedServer :: String -> Either String MemcachedServer
readMemcachedServer String
s = do
URI
uri <- forall a b. a -> Maybe b -> Either a b
note (String
"Not a valid URI: " forall a. Semigroup a => a -> a -> a
<> String
s) forall a b. (a -> b) -> a -> b
$ String -> Maybe URI
parseAbsoluteURI String
s
forall a b. a -> Maybe b -> Either a b
note String
"Must begin memcached://" forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ URI -> String
uriScheme URI
uri forall a. Eq a => a -> a -> Bool
== String
"memcached:"
let mAuth :: Maybe URIAuth
mAuth = URI -> Maybe URIAuth
uriAuthority URI
uri
forall (f :: * -> *) a. Applicative f => a -> f a
pure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerSpec -> MemcachedServer
MemcachedServer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id URIAuth -> ServerSpec -> ServerSpec
setHost Maybe URIAuth
mAuth
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id URIAuth -> ServerSpec -> ServerSpec
setPort Maybe URIAuth
mAuth
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id Authentication -> ServerSpec -> ServerSpec
setAuth (String -> Maybe Authentication
readAuthentication forall b c a. (b -> c) -> (a -> b) -> a -> c
. URIAuth -> String
uriUserInfo forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe URIAuth
mAuth)
forall a b. (a -> b) -> a -> b
$ forall a. Default a => a
Memcache.def
readAuthentication :: String -> Maybe Memcache.Authentication
readAuthentication :: String -> Maybe Authentication
readAuthentication = Text -> Maybe Authentication
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack
where
go :: Text -> Maybe Authentication
go Text
a = do
(Text
u, Text
p) <- forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (Int -> Text -> Text
T.drop Int
1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> (Text, Text)
T.breakOn Text
":" forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Text -> Maybe Text
T.stripSuffix Text
"@" Text
a
forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Text -> Bool
T.null Text
u
forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Text -> Bool
T.null Text
p
forall (f :: * -> *) a. Applicative f => a -> f a
pure
Memcache.Auth
{ username :: Username
Memcache.username = Text -> Username
encodeUtf8 Text
u
, password :: Username
Memcache.password = Text -> Username
encodeUtf8 Text
p
}
setHost :: URIAuth -> Memcache.ServerSpec -> Memcache.ServerSpec
setHost :: URIAuth -> ServerSpec -> ServerSpec
setHost URIAuth
auth ServerSpec
ss = case URIAuth -> String
uriRegName URIAuth
auth of
String
"" -> ServerSpec
ss
String
rn -> ServerSpec
ss {ssHost :: String
Memcache.ssHost = String
rn}
setPort :: URIAuth -> Memcache.ServerSpec -> Memcache.ServerSpec
setPort :: URIAuth -> ServerSpec -> ServerSpec
setPort URIAuth
auth ServerSpec
ss = forall a. a -> Maybe a -> a
fromMaybe ServerSpec
ss forall a b. (a -> b) -> a -> b
$ do
String
p <- case URIAuth -> String
uriPort URIAuth
auth of
String
"" -> forall a. Maybe a
Nothing
(Char
':' : String
p) -> forall {a}. a -> Maybe a
fromPort String
p
String
p -> forall {a}. a -> Maybe a
fromPort String
p
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ServerSpec
ss {ssPort :: String
Memcache.ssPort = String
p}
where
#if MIN_VERSION_memcache(0,3,0)
fromPort :: a -> Maybe a
fromPort = forall {a}. a -> Maybe a
Just
#else
fromPort = readMay
#endif
setAuth
:: Memcache.Authentication -> Memcache.ServerSpec -> Memcache.ServerSpec
setAuth :: Authentication -> ServerSpec -> ServerSpec
setAuth Authentication
auth ServerSpec
ss = ServerSpec
ss {ssAuth :: Authentication
Memcache.ssAuth = Authentication
auth}