module Faktory.Client
(
Client(..)
, newClient
, closeClient
, command_
, commandOK
, commandJSON
, commandByteString
) where
import Faktory.Prelude
import Control.Concurrent.MVar
import Crypto.Hash (Digest, SHA256(..), hashWith)
import Data.Aeson
import Data.Bitraversable (bimapM)
import Data.ByteArray (ByteArrayAccess)
import Data.ByteString.Lazy (ByteString, fromStrict)
import qualified Data.ByteString.Lazy.Char8 as BSL8
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Faktory.Connection (connect)
import Faktory.Protocol
import Faktory.Settings
import GHC.Stack
import Network.Connection
import Network.Socket (HostName)
import System.Posix.Process (getProcessID)
data Client = Client
{ Client -> MVar Connection
clientConnection :: MVar Connection
, Client -> Settings
clientSettings :: Settings
}
data HiPayload = HiPayload
{ HiPayload -> Int
hiVersion :: Int
, HiPayload -> Maybe Text
hiNonce :: Maybe Text
, HiPayload -> Maybe Int
hiIterations :: Maybe Int
}
instance FromJSON HiPayload where
parseJSON :: Value -> Parser HiPayload
parseJSON = String -> (Object -> Parser HiPayload) -> Value -> Parser HiPayload
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"HiPayload"
((Object -> Parser HiPayload) -> Value -> Parser HiPayload)
-> (Object -> Parser HiPayload) -> Value -> Parser HiPayload
forall a b. (a -> b) -> a -> b
$ \Object
o -> Int -> Maybe Text -> Maybe Int -> HiPayload
HiPayload (Int -> Maybe Text -> Maybe Int -> HiPayload)
-> Parser Int -> Parser (Maybe Text -> Maybe Int -> HiPayload)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Text -> Parser Int
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"v" Parser (Maybe Text -> Maybe Int -> HiPayload)
-> Parser (Maybe Text) -> Parser (Maybe Int -> HiPayload)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Text -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"s" Parser (Maybe Int -> HiPayload)
-> Parser (Maybe Int) -> Parser HiPayload
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Text -> Parser (Maybe Int)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"i"
data HelloPayload = HelloPayload
{ HelloPayload -> Maybe WorkerId
helloWorkerId :: Maybe WorkerId
, HelloPayload -> String
helloHostname :: HostName
, HelloPayload -> Integer
helloProcessId :: Integer
, HelloPayload -> [Text]
helloLabels :: [Text]
, HelloPayload -> Int
helloVersion :: Int
, HelloPayload -> Maybe Text
helloPasswordHash :: Maybe Text
}
instance ToJSON HelloPayload where
toJSON :: HelloPayload -> Value
toJSON HelloPayload {Int
Integer
String
[Text]
Maybe Text
Maybe WorkerId
helloPasswordHash :: Maybe Text
helloVersion :: Int
helloLabels :: [Text]
helloProcessId :: Integer
helloHostname :: String
helloWorkerId :: Maybe WorkerId
helloPasswordHash :: HelloPayload -> Maybe Text
helloVersion :: HelloPayload -> Int
helloLabels :: HelloPayload -> [Text]
helloProcessId :: HelloPayload -> Integer
helloHostname :: HelloPayload -> String
helloWorkerId :: HelloPayload -> Maybe WorkerId
..} = [Pair] -> Value
object
[ Text
"wid" Text -> Maybe WorkerId -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Maybe WorkerId
helloWorkerId
, Text
"hostname" Text -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= String
helloHostname
, Text
"pid" Text -> Integer -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Integer
helloProcessId
, Text
"labels" Text -> [Text] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= [Text]
helloLabels
, Text
"v" Text -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Int
helloVersion
, Text
"pwdhash" Text -> Maybe Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Maybe Text
helloPasswordHash
]
toEncoding :: HelloPayload -> Encoding
toEncoding HelloPayload {Int
Integer
String
[Text]
Maybe Text
Maybe WorkerId
helloPasswordHash :: Maybe Text
helloVersion :: Int
helloLabels :: [Text]
helloProcessId :: Integer
helloHostname :: String
helloWorkerId :: Maybe WorkerId
helloPasswordHash :: HelloPayload -> Maybe Text
helloVersion :: HelloPayload -> Int
helloLabels :: HelloPayload -> [Text]
helloProcessId :: HelloPayload -> Integer
helloHostname :: HelloPayload -> String
helloWorkerId :: HelloPayload -> Maybe WorkerId
..} = Series -> Encoding
pairs (Series -> Encoding) -> Series -> Encoding
forall a b. (a -> b) -> a -> b
$ [Series] -> Series
forall a. Monoid a => [a] -> a
mconcat
[ Text
"wid" Text -> Maybe WorkerId -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Maybe WorkerId
helloWorkerId
, Text
"hostname" Text -> String -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= String
helloHostname
, Text
"pid" Text -> Integer -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Integer
helloProcessId
, Text
"labels" Text -> [Text] -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= [Text]
helloLabels
, Text
"v" Text -> Int -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Int
helloVersion
, Text
"pwdhash" Text -> Maybe Text -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Maybe Text
helloPasswordHash
]
newClient :: HasCallStack => Settings -> Maybe WorkerId -> IO Client
newClient :: Settings -> Maybe WorkerId -> IO Client
newClient settings :: Settings
settings@Settings {ConnectionInfo
String -> IO ()
settingsLogError :: Settings -> String -> IO ()
settingsLogDebug :: Settings -> String -> IO ()
settingsConnection :: Settings -> ConnectionInfo
settingsLogError :: String -> IO ()
settingsLogDebug :: String -> IO ()
settingsConnection :: ConnectionInfo
..} Maybe WorkerId
mWorkerId =
IO Connection
-> (Connection -> IO ()) -> (Connection -> IO Client) -> IO Client
forall (m :: * -> *) a b c.
MonadMask m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracketOnError (ConnectionInfo -> IO Connection
connect ConnectionInfo
settingsConnection) Connection -> IO ()
connectionClose ((Connection -> IO Client) -> IO Client)
-> (Connection -> IO Client) -> IO Client
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> do
Client
client <- MVar Connection -> Settings -> Client
Client (MVar Connection -> Settings -> Client)
-> IO (MVar Connection) -> IO (Settings -> Client)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection -> IO (MVar Connection)
forall a. a -> IO (MVar a)
newMVar Connection
conn IO (Settings -> Client) -> IO Settings -> IO Client
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Settings -> IO Settings
forall (f :: * -> *) a. Applicative f => a -> f a
pure Settings
settings
ByteString
greeting <-
String -> Maybe ByteString -> IO ByteString
forall (m :: * -> *) a. MonadThrow m => String -> Maybe a -> m a
fromJustThrows String
"Unexpected end of HI message"
(Maybe ByteString -> IO ByteString)
-> IO (Maybe ByteString) -> IO ByteString
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Either String (Maybe ByteString) -> IO (Maybe ByteString)
forall (m :: * -> *) a. MonadThrow m => Either String a -> m a
fromRightThrows
(Either String (Maybe ByteString) -> IO (Maybe ByteString))
-> IO (Either String (Maybe ByteString)) -> IO (Maybe ByteString)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Settings -> Connection -> IO (Either String (Maybe ByteString))
recvUnsafe Settings
settings Connection
conn
ByteString
stripped <-
String -> Maybe ByteString -> IO ByteString
forall (m :: * -> *) a. MonadThrow m => String -> Maybe a -> m a
fromJustThrows (String
"Missing HI prefix: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall a. Show a => a -> String
show ByteString
greeting)
(Maybe ByteString -> IO ByteString)
-> Maybe ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> Maybe ByteString
BSL8.stripPrefix ByteString
"HI" ByteString
greeting
HiPayload {Int
Maybe Int
Maybe Text
hiIterations :: Maybe Int
hiNonce :: Maybe Text
hiVersion :: Int
hiIterations :: HiPayload -> Maybe Int
hiNonce :: HiPayload -> Maybe Text
hiVersion :: HiPayload -> Int
..} <-
String -> Maybe HiPayload -> IO HiPayload
forall (m :: * -> *) a. MonadThrow m => String -> Maybe a -> m a
fromJustThrows (String
"Failed to parse HI payload: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall a. Show a => a -> String
show ByteString
stripped)
(Maybe HiPayload -> IO HiPayload)
-> Maybe HiPayload -> IO HiPayload
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe HiPayload
forall a. FromJSON a => ByteString -> Maybe a
decode ByteString
stripped
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
hiVersion Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
expectedProtocolVersion) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
settingsLogError (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ String
"Server's protocol version "
, Int -> String
forall a. Show a => a -> String
show Int
hiVersion
, String
" higher than client's expected protocol version "
, Int -> String
forall a. Show a => a -> String
show Int
expectedProtocolVersion
]
let
mPassword :: Maybe String
mPassword = ConnectionInfo -> Maybe String
connectionInfoPassword ConnectionInfo
settingsConnection
mHashedPassword :: Maybe Text
mHashedPassword = Text -> Int -> String -> Text
hashPassword (Text -> Int -> String -> Text)
-> Maybe Text -> Maybe (Int -> String -> Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
hiNonce Maybe (Int -> String -> Text)
-> Maybe Int -> Maybe (String -> Text)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Int
hiIterations Maybe (String -> Text) -> Maybe String -> Maybe Text
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe String
mPassword
HelloPayload
helloPayload <-
Maybe WorkerId
-> String -> Integer -> [Text] -> Int -> Maybe Text -> HelloPayload
HelloPayload Maybe WorkerId
mWorkerId (String -> String
forall a. Show a => a -> String
show (String -> String)
-> ((String, PortNumber) -> String)
-> (String, PortNumber)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, PortNumber) -> String
forall a b. (a, b) -> a
fst ((String, PortNumber) -> String) -> (String, PortNumber) -> String
forall a b. (a -> b) -> a -> b
$ Connection -> (String, PortNumber)
connectionID Connection
conn)
(Integer -> [Text] -> Int -> Maybe Text -> HelloPayload)
-> IO Integer -> IO ([Text] -> Int -> Maybe Text -> HelloPayload)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ProcessID -> Integer
forall a. Integral a => a -> Integer
toInteger (ProcessID -> Integer) -> IO ProcessID -> IO Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO ProcessID
getProcessID)
IO ([Text] -> Int -> Maybe Text -> HelloPayload)
-> IO [Text] -> IO (Int -> Maybe Text -> HelloPayload)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Text] -> IO [Text]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Text
"haskell"]
IO (Int -> Maybe Text -> HelloPayload)
-> IO Int -> IO (Maybe Text -> HelloPayload)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> IO Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
expectedProtocolVersion
IO (Maybe Text -> HelloPayload)
-> IO (Maybe Text) -> IO HelloPayload
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Text -> IO (Maybe Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Text
mHashedPassword
HasCallStack => Client -> ByteString -> [ByteString] -> IO ()
Client -> ByteString -> [ByteString] -> IO ()
commandOK Client
client ByteString
"HELLO" [HelloPayload -> ByteString
forall a. ToJSON a => a -> ByteString
encode HelloPayload
helloPayload]
Client -> IO Client
forall (f :: * -> *) a. Applicative f => a -> f a
pure Client
client
where fromJustThrows :: String -> Maybe a -> m a
fromJustThrows String
message = m a -> (a -> m a) -> Maybe a -> m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> m a
forall (m :: * -> *) a.
(MonadThrow m, HasCallStack) =>
String -> m a
throwString String
message) a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
closeClient :: Client -> IO ()
closeClient :: Client -> IO ()
closeClient Client {MVar Connection
Settings
clientSettings :: Settings
clientConnection :: MVar Connection
clientSettings :: Client -> Settings
clientConnection :: Client -> MVar Connection
..} = MVar Connection -> (Connection -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar Connection
clientConnection ((Connection -> IO ()) -> IO ()) -> (Connection -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> do
Settings -> Connection -> ByteString -> [ByteString] -> IO ()
sendUnsafe Settings
clientSettings Connection
conn ByteString
"END" []
Connection -> IO ()
connectionClose Connection
conn
command_ :: Client -> ByteString -> [ByteString] -> IO ()
command_ :: Client -> ByteString -> [ByteString] -> IO ()
command_ Client
client ByteString
cmd [ByteString]
args = do
Either String (Maybe ByteString)
response <- Client
-> ByteString
-> [ByteString]
-> IO (Either String (Maybe ByteString))
commandByteString Client
client ByteString
cmd [ByteString]
args
IO (Maybe ByteString) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe ByteString) -> IO ()) -> IO (Maybe ByteString) -> IO ()
forall a b. (a -> b) -> a -> b
$ Either String (Maybe ByteString) -> IO (Maybe ByteString)
forall (m :: * -> *) a. MonadThrow m => Either String a -> m a
fromRightThrows Either String (Maybe ByteString)
response
commandOK :: HasCallStack => Client -> ByteString -> [ByteString] -> IO ()
commandOK :: Client -> ByteString -> [ByteString] -> IO ()
commandOK Client
client ByteString
cmd [ByteString]
args = do
Either String (Maybe ByteString)
response <- Client
-> ByteString
-> [ByteString]
-> IO (Either String (Maybe ByteString))
commandByteString Client
client ByteString
cmd [ByteString]
args
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Either String (Maybe ByteString)
response Either String (Maybe ByteString)
-> Either String (Maybe ByteString) -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe ByteString -> Either String (Maybe ByteString)
forall a b. b -> Either a b
Right (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
"OK"))
(IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall (m :: * -> *) a.
(MonadThrow m, HasCallStack) =>
String -> m a
throwString
(String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Server not OK. Reply was: "
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Either String (Maybe ByteString) -> String
forall a. Show a => a -> String
show Either String (Maybe ByteString)
response
commandJSON
:: FromJSON a
=> Client
-> ByteString
-> [ByteString]
-> IO (Either String (Maybe a))
commandJSON :: Client
-> ByteString -> [ByteString] -> IO (Either String (Maybe a))
commandJSON Client
client ByteString
cmd [ByteString]
args = do
Either String (Maybe ByteString)
emByteString <- Client
-> ByteString
-> [ByteString]
-> IO (Either String (Maybe ByteString))
commandByteString Client
client ByteString
cmd [ByteString]
args
(String -> IO (Either String (Maybe a)))
-> (Maybe ByteString -> IO (Either String (Maybe a)))
-> Either String (Maybe ByteString)
-> IO (Either String (Maybe a))
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Either String (Maybe a) -> IO (Either String (Maybe a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String (Maybe a) -> IO (Either String (Maybe a)))
-> (String -> Either String (Maybe a))
-> String
-> IO (Either String (Maybe a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String (Maybe a)
forall a b. a -> Either a b
Left) (Either String (Maybe a) -> IO (Either String (Maybe a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String (Maybe a) -> IO (Either String (Maybe a)))
-> (Maybe ByteString -> Either String (Maybe a))
-> Maybe ByteString
-> IO (Either String (Maybe a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Either String a)
-> Maybe ByteString -> Either String (Maybe a)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ByteString -> Either String a
forall a. FromJSON a => ByteString -> Either String a
eitherDecode) Either String (Maybe ByteString)
emByteString
commandByteString
:: Client
-> ByteString
-> [ByteString]
-> IO (Either String (Maybe ByteString))
commandByteString :: Client
-> ByteString
-> [ByteString]
-> IO (Either String (Maybe ByteString))
commandByteString Client {MVar Connection
Settings
clientSettings :: Settings
clientConnection :: MVar Connection
clientSettings :: Client -> Settings
clientConnection :: Client -> MVar Connection
..} ByteString
cmd [ByteString]
args = MVar Connection
-> (Connection -> IO (Either String (Maybe ByteString)))
-> IO (Either String (Maybe ByteString))
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar Connection
clientConnection ((Connection -> IO (Either String (Maybe ByteString)))
-> IO (Either String (Maybe ByteString)))
-> (Connection -> IO (Either String (Maybe ByteString)))
-> IO (Either String (Maybe ByteString))
forall a b. (a -> b) -> a -> b
$ \Connection
conn ->
do
Settings -> Connection -> ByteString -> [ByteString] -> IO ()
sendUnsafe Settings
clientSettings Connection
conn ByteString
cmd [ByteString]
args
Settings -> Connection -> IO (Either String (Maybe ByteString))
recvUnsafe Settings
clientSettings Connection
conn
sendUnsafe :: Settings -> Connection -> ByteString -> [ByteString] -> IO ()
sendUnsafe :: Settings -> Connection -> ByteString -> [ByteString] -> IO ()
sendUnsafe Settings {ConnectionInfo
String -> IO ()
settingsLogError :: String -> IO ()
settingsLogDebug :: String -> IO ()
settingsConnection :: ConnectionInfo
settingsLogError :: Settings -> String -> IO ()
settingsLogDebug :: Settings -> String -> IO ()
settingsConnection :: Settings -> ConnectionInfo
..} Connection
conn ByteString
cmd [ByteString]
args = do
let bs :: ByteString
bs = [ByteString] -> ByteString
BSL8.unwords (ByteString
cmd ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: [ByteString]
args)
String -> IO ()
settingsLogDebug (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"> " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall a. Show a => a -> String
show ByteString
bs
IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO ()) -> (ByteString -> IO ()) -> ByteString -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Connection -> ByteString -> IO ()
connectionPut Connection
conn (ByteString -> IO ())
-> (ByteString -> ByteString) -> ByteString -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BSL8.toStrict (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString
bs ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"\n"
recvUnsafe :: Settings -> Connection -> IO (Either String (Maybe ByteString))
recvUnsafe :: Settings -> Connection -> IO (Either String (Maybe ByteString))
recvUnsafe Settings {ConnectionInfo
String -> IO ()
settingsLogError :: String -> IO ()
settingsLogDebug :: String -> IO ()
settingsConnection :: ConnectionInfo
settingsLogError :: Settings -> String -> IO ()
settingsLogDebug :: Settings -> String -> IO ()
settingsConnection :: Settings -> ConnectionInfo
..} Connection
conn = do
Either String (Maybe ByteString)
emByteString <- IO ByteString -> IO (Either String (Maybe ByteString))
readReply (IO ByteString -> IO (Either String (Maybe ByteString)))
-> IO ByteString -> IO (Either String (Maybe ByteString))
forall a b. (a -> b) -> a -> b
$ Connection -> Int -> IO ByteString
connectionGet Connection
conn Int
4096
String -> IO ()
settingsLogDebug (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"< " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Either String (Maybe ByteString) -> String
forall a. Show a => a -> String
show Either String (Maybe ByteString)
emByteString
(String -> IO String)
-> (Maybe ByteString -> IO (Maybe ByteString))
-> Either String (Maybe ByteString)
-> IO (Either String (Maybe ByteString))
forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bitraversable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bimapM String -> IO String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ByteString -> IO (Maybe ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ByteString -> IO (Maybe ByteString))
-> (Maybe ByteString -> Maybe ByteString)
-> Maybe ByteString
-> IO (Maybe ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> ByteString) -> Maybe ByteString -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> ByteString
fromStrict) Either String (Maybe ByteString)
emByteString
times :: Int -> (s -> s) -> s -> s
times :: Int -> (s -> s) -> s -> s
times Int
n s -> s
f !s
s
| Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = s
s
| Bool
otherwise = Int -> (s -> s) -> s -> s
forall s. Int -> (s -> s) -> s -> s
times (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) s -> s
f (s -> s
f s
s)
hashPassword :: Text -> Int -> String -> Text
hashPassword :: Text -> Int -> String -> Text
hashPassword Text
nonce Int
n String
password =
String -> Text
T.pack
(String -> Text) -> (Text -> String) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Digest SHA256 -> String
forall a. Show a => a -> String
show
(Digest SHA256 -> String)
-> (Text -> Digest SHA256) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int
-> (Digest SHA256 -> Digest SHA256)
-> Digest SHA256
-> Digest SHA256
forall s. Int -> (s -> s) -> s -> s
times (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Digest SHA256 -> Digest SHA256
forall b. ByteArrayAccess b => b -> Digest SHA256
hash
(Digest SHA256 -> Digest SHA256)
-> (Text -> Digest SHA256) -> Text -> Digest SHA256
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Digest SHA256
forall b. ByteArrayAccess b => b -> Digest SHA256
hash
(ByteString -> Digest SHA256)
-> (Text -> ByteString) -> Text -> Digest SHA256
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
T.encodeUtf8
(Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
password
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
nonce
where
hash :: (ByteArrayAccess b) => b -> Digest SHA256
hash :: b -> Digest SHA256
hash = SHA256 -> b -> Digest SHA256
forall ba alg.
(ByteArrayAccess ba, HashAlgorithm alg) =>
alg -> ba -> Digest alg
hashWith SHA256
SHA256
expectedProtocolVersion :: Int
expectedProtocolVersion :: Int
expectedProtocolVersion = Int
2