-- |
-- 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 (encodeUtf8, decodeUtf8')

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
  { Codec s -> Text
mimeType :: Text, -- ^ MIME type sent to the server
    Codec s -> RequestMessage -> ByteString
encodeWith :: RequestMessage -> BSL.ByteString, -- ^ Request encoder
    Codec s -> ByteString -> Either String (ResponseMessage s)
decodeWith :: BSL.ByteString -> Either String (ResponseMessage s) -- ^ Response decoder
  }

instance Functor Codec where
  fmap :: (a -> b) -> Codec a -> Codec b
fmap a -> b
f Codec a
c = Codec a
c { decodeWith :: ByteString -> Either String (ResponseMessage b)
decodeWith = ((Either String (ResponseMessage a)
 -> Either String (ResponseMessage b))
-> (ByteString -> Either String (ResponseMessage a))
-> ByteString
-> Either String (ResponseMessage b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Either String (ResponseMessage a)
  -> Either String (ResponseMessage b))
 -> (ByteString -> Either String (ResponseMessage a))
 -> ByteString
 -> Either String (ResponseMessage b))
-> ((a -> b)
    -> Either String (ResponseMessage a)
    -> Either String (ResponseMessage b))
-> (a -> b)
-> (ByteString -> Either String (ResponseMessage a))
-> ByteString
-> Either String (ResponseMessage b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ResponseMessage a -> ResponseMessage b)
-> Either String (ResponseMessage a)
-> Either String (ResponseMessage b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((ResponseMessage a -> ResponseMessage b)
 -> Either String (ResponseMessage a)
 -> Either String (ResponseMessage b))
-> ((a -> b) -> ResponseMessage a -> ResponseMessage b)
-> (a -> b)
-> Either String (ResponseMessage a)
-> Either String (ResponseMessage b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b) -> ResponseMessage a -> ResponseMessage b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) a -> b
f ((ByteString -> Either String (ResponseMessage a))
 -> ByteString -> Either String (ResponseMessage b))
-> (ByteString -> Either String (ResponseMessage a))
-> ByteString
-> Either String (ResponseMessage b)
forall a b. (a -> b) -> a -> b
$ Codec a -> ByteString -> Either String (ResponseMessage a)
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 ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
mime_bin
  where
    size :: Word8
size = Int64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Word8) -> Int64 -> Word8
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 (ByteString -> ByteString) -> ByteString -> ByteString
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 :: Codec s -> RequestMessage -> ByteString
encodeBinaryWith Codec s
c RequestMessage
req = Text -> ByteString
messageHeader (Codec s -> Text
forall s. Codec s -> Text
mimeType Codec s
c) ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Codec s -> RequestMessage -> ByteString
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 -> String -> Either String (Text, ByteString)
forall a b. a -> Either a b
Left String
"Length of MIME type is missing in the header."
   Just (Word8
mime_len, ByteString
rest) -> Word8 -> ByteString -> Either String (Text, ByteString)
forall a.
Integral a =>
a -> ByteString -> Either String (Text, ByteString)
decodeMimeAndPayload Word8
mime_len ByteString
rest
  where
    decodeMimeAndPayload :: a -> ByteString -> Either String (Text, ByteString)
decodeMimeAndPayload a
mime_lenw ByteString
msg = do
      Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Int64
BSL.length ByteString
mime_field Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
/= Int64
mime_len) (Either String () -> Either String ())
-> Either String () -> Either String ()
forall a b. (a -> b) -> a -> b
$ String -> Either String ()
forall a b. a -> Either a b
Left (String
"Too short MIME field: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall a. Show a => a -> String
show ByteString
mime_field)
      Text
mime_text <- (UnicodeException -> Either String Text)
-> (Text -> Either String Text)
-> Either UnicodeException Text
-> Either String Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Either String Text
forall a b. a -> Either a b
Left (String -> Either String Text)
-> (UnicodeException -> String)
-> UnicodeException
-> Either String Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnicodeException -> String
forall a. Show a => a -> String
show) Text -> Either String Text
forall a b. b -> Either a b
Right (Either UnicodeException Text -> Either String Text)
-> Either UnicodeException Text -> Either String Text
forall a b. (a -> b) -> a -> b
$ ByteString -> Either UnicodeException Text
decodeUtf8' (ByteString -> Either UnicodeException Text)
-> ByteString -> Either UnicodeException Text
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BSL.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString
mime_field
      (Text, ByteString) -> Either String (Text, ByteString)
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 = a -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
mime_lenw