{-|

Module      : Network.Gemini.Capsule.Encoding
Description : funcitons to encode/decode our data types
Copyright   : (C) Jonathan Lamothe
License     : AGPL-3.0-or-later
Maintainer  : jonathan@jlamothe.net
Stability   : experimental
Portability : POSIX

This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Affero General Public License as
published by the Free Software Foundation, either version 3 of the
License, or (at your option) any later version.

This program is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
Affero General Public License for more details.

You should have received a copy of the GNU Affero General Public
License along with this program.  If not, see
<https://www.gnu.org/licenses/>.

-}

{-# LANGUAGE LambdaCase, OverloadedStrings, RecordWildCards #-}

module Network.Gemini.Capsule.Encoding (
  encodeGemURL,
  decodeGemURL,
  escapeString,
  unescapeString,
  encodeGemResponse
) where

import qualified Data.ByteString as BS
import Data.ByteString.Builder (
  charUtf8,
  lazyByteString,
  stringUtf8,
  toLazyByteString,
  word8Dec)
import qualified Data.ByteString.Lazy as BSL
import Data.Char (chr, ord, toLower)
import Data.List (find, intercalate)
import Data.Maybe (fromJust, fromMaybe)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8')

import Network.Gemini.Capsule.Types

-- | Encodes a 'GemURL' into a 'String'
encodeGemURL :: GemURL -> String
encodeGemURL :: GemURL -> String
encodeGemURL GemURL
url =
  String
"gemini://" forall a. [a] -> [a] -> [a]
++ String
authority forall a. [a] -> [a] -> [a]
++ String
"/" forall a. [a] -> [a] -> [a]
++ String
path forall a. [a] -> [a] -> [a]
++ String
query
  where
    authority :: String
authority = GemURL -> String
gemHost GemURL
url forall a. [a] -> [a] -> [a]
++ case GemURL -> Maybe Word32
gemPort GemURL
url of
      Just Word32
port -> Char
':' forall a. a -> [a] -> [a]
: forall a. Show a => a -> String
show Word32
port
      Maybe Word32
Nothing   -> String
""
    path :: String
path = forall a. [a] -> [[a]] -> [a]
intercalate String
"/" forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map String -> String
escapeString forall a b. (a -> b) -> a -> b
$ GemURL -> [String]
gemPath GemURL
url
    query :: String
query = case GemURL -> Maybe String
gemQuery GemURL
url of
      Maybe String
Nothing -> String
""
      Just String
q  -> Char
'?' forall a. a -> [a] -> [a]
: String -> String
escapeString String
q

-- | Decodes a 'GemURL' from a 'String' (if possible)
decodeGemURL :: String -> Maybe GemURL
decodeGemURL :: String -> Maybe GemURL
decodeGemURL String
str = do
  let txt :: Text
txt = String -> Text
T.pack String
str

  Text
noProt <- case Text -> Text -> [Text]
T.splitOn Text
"://" Text
txt of
    [Text
prot, Text
rest] -> if Text -> Text
T.toLower Text
prot forall a. Eq a => a -> a -> Bool
== Text
"gemini"
      then forall a. a -> Maybe a
Just Text
rest
      else forall a. Maybe a
Nothing
    [Text]
_ -> forall a. Maybe a
Nothing

  Text
noFrag <- case Text -> Text -> [Text]
T.splitOn Text
"#" Text
noProt of
    [Text
x, Text
_] -> forall a. a -> Maybe a
Just Text
x
    [Text
x]    -> forall a. a -> Maybe a
Just Text
x
    [Text]
_      -> forall a. Maybe a
Nothing

  (Text
noQuery, Maybe Text
query) <- case Text -> Text -> [Text]
T.splitOn Text
"?" Text
noFrag of
    [Text
nq, Text
q] -> forall a. a -> Maybe a
Just (Text
nq, forall a. a -> Maybe a
Just Text
q)
    [Text
nq]    -> forall a. a -> Maybe a
Just (Text
nq, forall a. Maybe a
Nothing)
    [Text]
_       -> forall a. Maybe a
Nothing

  Maybe String
gemQuery <- case Maybe Text
query of
    Just Text
q  -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Maybe String
unescapeString (Text -> String
T.unpack Text
q)
    Maybe Text
Nothing -> forall a. a -> Maybe a
Just forall a. Maybe a
Nothing

  (Text
auth, [Text]
path) <- case Text -> Text -> [Text]
T.splitOn Text
"/" Text
noQuery of
    [Text
a]     -> forall a. a -> Maybe a
Just (Text
a, [])
    [Text
a, Text
""] -> forall a. a -> Maybe a
Just (Text
a, [])
    Text
a:[Text]
ps    -> forall a. a -> Maybe a
Just (Text
a, [Text]
ps)
    [Text]
_       -> forall a. Maybe a
Nothing

  [String]
gemPath  <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String -> Maybe String
unescapeString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack) [Text]
path

  (Text
host, Maybe Word32
gemPort) <- case Text -> Text -> [Text]
T.splitOn Text
":" Text
auth of
    [Text
h, Text
p] -> case forall a. Read a => ReadS a
reads forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
p of
      [(Word32
n, String
"")] -> forall a. a -> Maybe a
Just (Text
h, forall a. a -> Maybe a
Just Word32
n)
      [(Word32, String)]
_         -> forall a. Maybe a
Nothing
    [Text
h] -> forall a. a -> Maybe a
Just (Text
h, forall a. Maybe a
Nothing)
    [Text]
_   -> forall a. Maybe a
Nothing

  let gemHost :: String
gemHost = Text -> String
T.unpack Text
host
  forall a. a -> Maybe a
Just GemURL {String
[String]
Maybe String
Maybe Word32
gemHost :: String
gemPort :: Maybe Word32
gemPath :: [String]
gemQuery :: Maybe String
gemQuery :: Maybe String
gemPath :: [String]
gemPort :: Maybe Word32
gemHost :: String
..}

-- | add required escape sequences to a string
escapeString :: String -> String
escapeString :: String -> String
escapeString = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
  ( \Word8
n -> let ch :: Char
ch = Int -> Char
chr forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
n in
    if Char
ch forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
unescaped
    then [Char
ch]
    else Char
'%' forall a. a -> [a] -> [a]
: Word8 -> String
toHex Word8
n
  ) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Word8]
BSL.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
toLazyByteString forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Builder
stringUtf8
  where
    unescaped :: String
unescaped = [Char
'0'..Char
'9'] forall a. [a] -> [a] -> [a]
++ [Char
'A'..Char
'Z'] forall a. [a] -> [a] -> [a]
++ [Char
'a'..Char
'z'] forall a. [a] -> [a] -> [a]
++ String
"~-_."
    toHex :: Word8 -> String
toHex =
      ( \Int
n -> let
        high :: Int
high = Int
n forall a. Integral a => a -> a -> a
`div` Int
16
        low :: Int
low  = Int
n forall a. Integral a => a -> a -> a
`mod` Int
16
        in [String
hexDigits forall a. [a] -> Int -> a
!! Int
high, String
hexDigits forall a. [a] -> Int -> a
!! Int
low]
      ) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral

-- | decode an escaped string back to its original value
unescapeString :: String -> Maybe String
unescapeString :: String -> Maybe String
unescapeString String
str = case ByteString -> Either UnicodeException Text
decodeUtf8' forall a b. (a -> b) -> a -> b
$ [Word8] -> ByteString
BS.pack forall a b. (a -> b) -> a -> b
$ String -> [Word8]
toBytes String
str of
    Right Text
t -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
t
    Either UnicodeException Text
_       -> forall a. Maybe a
Nothing
  where
    toBytes :: String -> [Word8]
toBytes = \case
      String
"" -> []
      Char
'%':Char
h:Char
l:String
sub -> let
        h' :: Char
h' = Char -> Char
toLower Char
h
        l' :: Char
l' = Char -> Char
toLower Char
l
        in if Char
h' forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
hexDigits Bool -> Bool -> Bool
&& Char
l' forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
hexDigits
        then forall {a}. (Num a, Enum a) => Char -> Char -> a
toByte Char
h' Char
l' forall a. a -> [a] -> [a]
: String -> [Word8]
toBytes String
sub
        else forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
'%') forall a. a -> [a] -> [a]
: String -> [Word8]
toBytes (Char
h forall a. a -> [a] -> [a]
: Char
l forall a. a -> [a] -> [a]
: String
sub)
      Char
ch:String
sub ->
        ByteString -> [Word8]
BSL.unpack (Builder -> ByteString
toLazyByteString forall a b. (a -> b) -> a -> b
$ Char -> Builder
charUtf8 Char
ch) forall a. [a] -> [a] -> [a]
++ String -> [Word8]
toBytes String
sub
    toByte :: Char -> Char -> a
toByte Char
h Char
l = forall {a}. (Num a, Enum a) => Char -> a
toNum Char
h forall a. Num a => a -> a -> a
* a
16 forall a. Num a => a -> a -> a
+ forall {a}. (Num a, Enum a) => Char -> a
toNum Char
l
    toNum :: Char -> a
toNum Char
ch = forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$
      forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(a, Char)
x -> forall a b. (a, b) -> b
snd (a, Char)
x forall a. Eq a => a -> a -> Bool
== Char
ch) forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [a
0..] String
hexDigits

-- | encodes a 'GemResponse' into a lazy ByteString
encodeGemResponse :: GemResponse -> BSL.ByteString
encodeGemResponse :: GemResponse -> ByteString
encodeGemResponse GemResponse
resp = let
  code :: Word8
code = GemResponse -> Word8
respStatus GemResponse
resp
  meta :: String
meta = GemResponse -> String
respMeta GemResponse
resp
  body :: ByteString
body = forall a. a -> Maybe a -> a
fromMaybe ByteString
"" forall a b. (a -> b) -> a -> b
$ GemResponse -> Maybe ByteString
respBody GemResponse
resp

  builder :: Builder
builder
    =  Word8 -> Builder
word8Dec Word8
code
    forall a. Semigroup a => a -> a -> a
<> Char -> Builder
charUtf8 Char
' '
    forall a. Semigroup a => a -> a -> a
<> String -> Builder
stringUtf8 String
meta
    forall a. Semigroup a => a -> a -> a
<> String -> Builder
stringUtf8 String
"\r\n"
    forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
lazyByteString ByteString
body

  in Builder -> ByteString
toLazyByteString Builder
builder

hexDigits :: String
hexDigits :: String
hexDigits = [Char
'0'..Char
'9'] forall a. [a] -> [a] -> [a]
++ [Char
'a'..Char
'f']

--jl