module Faktory.Client
  (
  -- * Client operations
    Client(..)
  , newClient
  , closeClient

  -- * High-level Client API
  , 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
  }

-- | <https://github.com/contribsys/faktory/wiki/Worker-Lifecycle#initial-handshake>
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 -- TODO: Orphan ToJSON ProcessID
  , 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
    ]

-- | Open a new @'Client'@ connection with the given @'Settings'@
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

-- | Close a @'Client'@
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

-- | Send a command, read and discard the response
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

-- | Send a command, assert the response is @OK@
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

-- | Send a command, parse the response as JSON
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

-- | Send a command to the Server socket
--
-- Do not use outside of @'withMVar'@, this is not threadsafe.
--
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"

-- | Receive data from the Server socket
--
-- Do not use outside of @'withMVar'@, this is not threadsafe.
--
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

-- | Iteratively apply a function @n@ times
--
-- This is like @iterate f s !! n@ but strict in @s@
--
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)

-- | Hash password using provided @nonce@ for @n@ iterations
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
  -- Note that we use hash at two different types above.
  --
  -- 1. hash :: ByteString    -> Digest SHA256
  -- 2. hash :: Digest SHA256 -> Digest SHA256
  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

-- | Protocol version the client expects
expectedProtocolVersion :: Int
expectedProtocolVersion :: Int
expectedProtocolVersion = Int
2