{-# LANGUAGE CPP #-}

-- | Read a Memcached Servers value, to support ENV-based configuration
--
-- Format:
--
-- @
-- memcached://[user[:password]@]host][:port],...
-- @
--
-- Usage with "Freckle.App.Env":
--
-- @
-- -- Required
-- Env.var (Env.eitherReader readMemcachedServers <=< Env.nonempty) "MEMCACHED_SERVERS" mempty
--
-- -- Default to localhost:11211
-- Env.var (Env.eitherReader readMemcachedServers) "MEMCACHED_SERVERS" (Env.def defaultMemcachedServers)
--
-- -- Default to disabled
-- Env.var (Env.eitherReader readMemcachedServers) "MEMCACHED_SERVERS" (Env.def emptyMemcachedServers)
-- @
--
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)
  -- ssPort is a ServiceName, which is a String
  fromPort :: a -> Maybe a
fromPort = forall {a}. a -> Maybe a
Just
#else
  -- ssPort is a PortNumber, which we need to Read
  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 }