-- |
-- Module: Network.Greskell.WebSocket.Codec
-- Description: Encoder\/decoder of Request\/Response
-- Maintainer: Toshio Ito <debug.ito@gmail.com>
--
--
module Network.Greskell.WebSocket.Codec
    ( -- * Codec
      Codec (..)
      -- * Request encoder
    , encodeBinaryWith
    , messageHeader
      -- * Request decoder
    , decodeBinary
    ) where

import           Control.Monad                       (when)
import qualified Data.ByteString.Lazy                as BSL
import           Data.Monoid                         ((<>))
import           Data.Text                           (Text)
import           Data.Text.Encoding                  (decodeUtf8', encodeUtf8)

import           Network.Greskell.WebSocket.Request  (RequestMessage)
import           Network.Greskell.WebSocket.Response (ResponseMessage)

-- | Encoder of 'RequestMessage' and decoder of 'ResponseMessage',
-- associated with a MIME type.
--
-- Type @s@ is the body of Response.
data Codec s
  = Codec
      { forall s. Codec s -> Text
mimeType   :: Text
        -- ^ MIME type sent to the server
      , forall s. Codec s -> RequestMessage -> ByteString
encodeWith :: RequestMessage -> BSL.ByteString
        -- ^ Request encoder
      , forall s.
Codec s -> ByteString -> Either String (ResponseMessage s)
decodeWith :: BSL.ByteString -> Either String (ResponseMessage s)
        -- ^ Response decoder
      }

instance Functor Codec where
  fmap :: forall a b. (a -> b) -> Codec a -> Codec b
fmap a -> b
f Codec a
c = Codec a
c { decodeWith :: ByteString -> Either String (ResponseMessage b)
decodeWith = (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) a -> b
f forall a b. (a -> b) -> a -> b
$ forall s.
Codec s -> ByteString -> Either String (ResponseMessage s)
decodeWith Codec a
c }

-- | Make a request message header.
messageHeader :: Text -- ^ MIME type
              -> BSL.ByteString
messageHeader :: Text -> ByteString
messageHeader Text
mime = Word8 -> ByteString
BSL.singleton Word8
size forall a. Semigroup a => a -> a -> a
<> ByteString
mime_bin
  where
    size :: Word8
size = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
BSL.length ByteString
mime_bin -- what if 'mime' is too long??
    mime_bin :: ByteString
mime_bin = ByteString -> ByteString
BSL.fromStrict forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 Text
mime

-- | Encode a 'RequestMessage' into a \"binary\" format of Gremlin
-- Server. The result includes the message \"header\" and the
-- \"payload\".
encodeBinaryWith :: Codec s -> RequestMessage -> BSL.ByteString
encodeBinaryWith :: forall s. Codec s -> RequestMessage -> ByteString
encodeBinaryWith Codec s
c RequestMessage
req = Text -> ByteString
messageHeader (forall s. Codec s -> Text
mimeType Codec s
c) forall a. Semigroup a => a -> a -> a
<> forall s. Codec s -> RequestMessage -> ByteString
encodeWith Codec s
c RequestMessage
req

-- | Decode a message in the \"binary\" format. This is mainly for
-- testing purposes.
decodeBinary :: BSL.ByteString
             -> Either String (Text, BSL.ByteString) -- ^ (mimeType, payload)
decodeBinary :: ByteString -> Either String (Text, ByteString)
decodeBinary ByteString
raw_msg = do
  case ByteString -> Maybe (Word8, ByteString)
BSL.uncons ByteString
raw_msg of
   Maybe (Word8, ByteString)
Nothing               -> forall a b. a -> Either a b
Left String
"Length of MIME type is missing in the header."
   Just (Word8
mime_len, ByteString
rest) -> forall {p}.
Integral p =>
p -> ByteString -> Either String (Text, ByteString)
decodeMimeAndPayload Word8
mime_len ByteString
rest
  where
    decodeMimeAndPayload :: p -> ByteString -> Either String (Text, ByteString)
decodeMimeAndPayload p
mime_lenw ByteString
msg = do
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Int64
BSL.length ByteString
mime_field forall a. Eq a => a -> a -> Bool
/= Int64
mime_len) forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left (String
"Too short MIME field: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show ByteString
mime_field)
      Text
mime_text <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ ByteString -> Either UnicodeException Text
decodeUtf8' forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BSL.toStrict forall a b. (a -> b) -> a -> b
$ ByteString
mime_field
      forall (m :: * -> *) a. Monad m => a -> m a
return (Text
mime_text, ByteString
payload)
      where
        (ByteString
mime_field, ByteString
payload) = Int64 -> ByteString -> (ByteString, ByteString)
BSL.splitAt Int64
mime_len ByteString
msg
        mime_len :: Int64
mime_len = forall a b. (Integral a, Num b) => a -> b
fromIntegral p
mime_lenw