-- | 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 Prelude

import Control.Error.Util (note)
import Control.Monad (guard)
import Data.Bifunctor (second)
import Data.Maybe (fromMaybe)
import Data.Text qualified as T
import Data.Text.Encoding qualified as T
import Database.Memcache.Client qualified 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 =
  ([MemcachedServer] -> MemcachedServers)
-> Either String [MemcachedServer]
-> Either String MemcachedServers
forall a b. (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [MemcachedServer] -> MemcachedServers
MemcachedServers
    (Either String [MemcachedServer] -> Either String MemcachedServers)
-> (String -> Either String [MemcachedServer])
-> String
-> Either String MemcachedServers
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Either String MemcachedServer)
-> [Text] -> Either String [MemcachedServer]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (String -> Either String MemcachedServer
readMemcachedServer (String -> Either String MemcachedServer)
-> (Text -> String) -> Text -> Either String MemcachedServer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack)
    ([Text] -> Either String [MemcachedServer])
-> (String -> [Text]) -> String -> Either String [MemcachedServer]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
T.null)
    ([Text] -> [Text]) -> (String -> [Text]) -> String -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
T.strip
    ([Text] -> [Text]) -> (String -> [Text]) -> String -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
","
    (Text -> [Text]) -> (String -> Text) -> String -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack

toServerSpecs :: MemcachedServers -> [Memcache.ServerSpec]
toServerSpecs :: MemcachedServers -> [ServerSpec]
toServerSpecs = (MemcachedServer -> ServerSpec)
-> [MemcachedServer] -> [ServerSpec]
forall a b. (a -> b) -> [a] -> [b]
map MemcachedServer -> ServerSpec
unMemcachedServer ([MemcachedServer] -> [ServerSpec])
-> (MemcachedServers -> [MemcachedServer])
-> MemcachedServers
-> [ServerSpec]
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 ServerSpec
forall a. Default a => a
Memcache.def

readMemcachedServer :: String -> Either String MemcachedServer
readMemcachedServer :: String -> Either String MemcachedServer
readMemcachedServer String
s = do
  URI
uri <- String -> Maybe URI -> Either String URI
forall a b. a -> Maybe b -> Either a b
note (String
"Not a valid URI: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
s) (Maybe URI -> Either String URI) -> Maybe URI -> Either String URI
forall a b. (a -> b) -> a -> b
$ String -> Maybe URI
parseAbsoluteURI String
s
  String -> Maybe () -> Either String ()
forall a b. a -> Maybe b -> Either a b
note String
"Must begin memcached://" (Maybe () -> Either String ()) -> Maybe () -> Either String ()
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ URI -> String
uriScheme URI
uri String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"memcached:"

  let mAuth :: Maybe URIAuth
mAuth = URI -> Maybe URIAuth
uriAuthority URI
uri

  MemcachedServer -> Either String MemcachedServer
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (MemcachedServer -> Either String MemcachedServer)
-> (ServerSpec -> MemcachedServer)
-> ServerSpec
-> Either String MemcachedServer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerSpec -> MemcachedServer
MemcachedServer
    (ServerSpec -> MemcachedServer)
-> (ServerSpec -> ServerSpec) -> ServerSpec -> MemcachedServer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ServerSpec -> ServerSpec)
-> (URIAuth -> ServerSpec -> ServerSpec)
-> Maybe URIAuth
-> ServerSpec
-> ServerSpec
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ServerSpec -> ServerSpec
forall a. a -> a
id URIAuth -> ServerSpec -> ServerSpec
setHost Maybe URIAuth
mAuth
    (ServerSpec -> ServerSpec)
-> (ServerSpec -> ServerSpec) -> ServerSpec -> ServerSpec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ServerSpec -> ServerSpec)
-> (URIAuth -> ServerSpec -> ServerSpec)
-> Maybe URIAuth
-> ServerSpec
-> ServerSpec
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ServerSpec -> ServerSpec
forall a. a -> a
id URIAuth -> ServerSpec -> ServerSpec
setPort Maybe URIAuth
mAuth
    (ServerSpec -> ServerSpec)
-> (ServerSpec -> ServerSpec) -> ServerSpec -> ServerSpec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ServerSpec -> ServerSpec)
-> (Authentication -> ServerSpec -> ServerSpec)
-> Maybe Authentication
-> ServerSpec
-> ServerSpec
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ServerSpec -> ServerSpec
forall a. a -> a
id Authentication -> ServerSpec -> ServerSpec
setAuth (String -> Maybe Authentication
readAuthentication (String -> Maybe Authentication)
-> (URIAuth -> String) -> URIAuth -> Maybe Authentication
forall b c a. (b -> c) -> (a -> b) -> a -> c
. URIAuth -> String
uriUserInfo (URIAuth -> Maybe Authentication)
-> Maybe URIAuth -> Maybe Authentication
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe URIAuth
mAuth)
    (ServerSpec -> Either String MemcachedServer)
-> ServerSpec -> Either String MemcachedServer
forall a b. (a -> b) -> a -> b
$ ServerSpec
forall a. Default a => a
Memcache.def

readAuthentication :: String -> Maybe Memcache.Authentication
readAuthentication :: String -> Maybe Authentication
readAuthentication = Text -> Maybe Authentication
go (Text -> Maybe Authentication)
-> (String -> Text) -> String -> Maybe Authentication
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack
 where
  go :: Text -> Maybe Authentication
go Text
a = do
    (Text
u, Text
p) <- (Text -> Text) -> (Text, Text) -> (Text, Text)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (Int -> Text -> Text
T.drop Int
1) ((Text, Text) -> (Text, Text))
-> (Text -> (Text, Text)) -> Text -> (Text, Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
T.breakOn Text
":" (Text -> (Text, Text)) -> Maybe Text -> Maybe (Text, Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Text -> Maybe Text
T.stripSuffix Text
"@" Text
a

    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Text -> Bool
T.null Text
u
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Text -> Bool
T.null Text
p

    Authentication -> Maybe Authentication
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      Memcache.Auth
        { username :: Username
Memcache.username = Text -> Username
T.encodeUtf8 Text
u
        , password :: Username
Memcache.password = Text -> Username
T.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 {Memcache.ssHost = rn}

setPort :: URIAuth -> Memcache.ServerSpec -> Memcache.ServerSpec
setPort :: URIAuth -> ServerSpec -> ServerSpec
setPort URIAuth
auth ServerSpec
ss = ServerSpec -> Maybe ServerSpec -> ServerSpec
forall a. a -> Maybe a -> a
fromMaybe ServerSpec
ss (Maybe ServerSpec -> ServerSpec) -> Maybe ServerSpec -> ServerSpec
forall a b. (a -> b) -> a -> b
$ do
  String
p <- case URIAuth -> String
uriPort URIAuth
auth of
    String
"" -> Maybe String
forall a. Maybe a
Nothing
    (Char
':' : String
p) -> String -> Maybe String
forall a. a -> Maybe a
Just String
p
    String
p -> String -> Maybe String
forall a. a -> Maybe a
Just String
p
  ServerSpec -> Maybe ServerSpec
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ServerSpec -> Maybe ServerSpec) -> ServerSpec -> Maybe ServerSpec
forall a b. (a -> b) -> a -> b
$ ServerSpec
ss {Memcache.ssPort = p}

setAuth
  :: Memcache.Authentication -> Memcache.ServerSpec -> Memcache.ServerSpec
setAuth :: Authentication -> ServerSpec -> ServerSpec
setAuth Authentication
auth ServerSpec
ss = ServerSpec
ss {Memcache.ssAuth = auth}