{-|

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://" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
authority String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
path String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
query
  where
    authority :: String
authority = GemURL -> String
gemHost GemURL
url String -> String -> String
forall a. [a] -> [a] -> [a]
++ case GemURL -> Maybe Word32
gemPort GemURL
url of
      Just Word32
port -> Char
':' Char -> String -> String
forall a. a -> [a] -> [a]
: Word32 -> String
forall a. Show a => a -> String
show Word32
port
      Maybe Word32
Nothing   -> String
""
    path :: String
path = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"/" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
escapeString ([String] -> [String]) -> [String] -> [String]
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
'?' Char -> String -> String
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 Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"gemini"
      then Text -> Maybe Text
forall a. a -> Maybe a
Just Text
rest
      else Maybe Text
forall a. Maybe a
Nothing
    [Text]
_ -> Maybe Text
forall a. Maybe a
Nothing

  Text
noFrag <- case Text -> Text -> [Text]
T.splitOn Text
"#" Text
noProt of
    [Text
x, Text
_] -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
x
    [Text
x]    -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
x
    [Text]
_      -> Maybe 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] -> (Text, Maybe Text) -> Maybe (Text, Maybe Text)
forall a. a -> Maybe a
Just (Text
nq, Text -> Maybe Text
forall a. a -> Maybe a
Just Text
q)
    [Text
nq]    -> (Text, Maybe Text) -> Maybe (Text, Maybe Text)
forall a. a -> Maybe a
Just (Text
nq, Maybe Text
forall a. Maybe a
Nothing)
    [Text]
_       -> Maybe (Text, Maybe Text)
forall a. Maybe a
Nothing

  Maybe String
gemQuery <- case Maybe Text
query of
    Just Text
q  -> String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> Maybe String -> Maybe (Maybe String)
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 -> Maybe String -> Maybe (Maybe String)
forall a. a -> Maybe a
Just Maybe String
forall a. Maybe a
Nothing

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

  [String]
gemPath  <- (Text -> Maybe String) -> [Text] -> Maybe [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String -> Maybe String
unescapeString (String -> Maybe String)
-> (Text -> String) -> Text -> Maybe String
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 ReadS Word32
forall a. Read a => ReadS a
reads ReadS Word32 -> ReadS Word32
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
p of
      [(Word32
n, String
"")] -> (Text, Maybe Word32) -> Maybe (Text, Maybe Word32)
forall a. a -> Maybe a
Just (Text
h, Word32 -> Maybe Word32
forall a. a -> Maybe a
Just Word32
n)
      [(Word32, String)]
_         -> Maybe (Text, Maybe Word32)
forall a. Maybe a
Nothing
    [Text
h] -> (Text, Maybe Word32) -> Maybe (Text, Maybe Word32)
forall a. a -> Maybe a
Just (Text
h, Maybe Word32
forall a. Maybe a
Nothing)
    [Text]
_   -> Maybe (Text, Maybe Word32)
forall a. Maybe a
Nothing

  let gemHost :: String
gemHost = Text -> String
T.unpack Text
host
  GemURL -> Maybe GemURL
forall a. a -> Maybe a
Just GemURL :: String -> Maybe Word32 -> [String] -> Maybe String -> GemURL
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 = (Word8 -> String) -> [Word8] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
  ( \Word8
n -> let ch :: Char
ch = Int -> Char
chr (Int -> Char) -> Int -> Char
forall a b. (a -> b) -> a -> b
$ Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
n in
    if Char
ch Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
unescaped
    then [Char
ch]
    else Char
'%' Char -> String -> String
forall a. a -> [a] -> [a]
: Word8 -> String
toHex Word8
n
  ) ([Word8] -> String) -> (String -> [Word8]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Word8]
BSL.unpack (ByteString -> [Word8])
-> (String -> ByteString) -> String -> [Word8]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
toLazyByteString (Builder -> ByteString)
-> (String -> Builder) -> String -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Builder
stringUtf8
  where
    unescaped :: String
unescaped = [Char
'0'..Char
'9'] String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
'A'..Char
'Z'] String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
'a'..Char
'z'] String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"~-_."
    toHex :: Word8 -> String
toHex =
      ( \Int
n -> let
        high :: Int
high = Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
16
        low :: Int
low  = Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
16
        in [String
hexDigits String -> Int -> Char
forall a. [a] -> Int -> a
!! Int
high, String
hexDigits String -> Int -> Char
forall a. [a] -> Int -> a
!! Int
low]
      ) (Int -> String) -> (Word8 -> Int) -> Word8 -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Int
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' (ByteString -> Either UnicodeException Text)
-> ByteString -> Either UnicodeException Text
forall a b. (a -> b) -> a -> b
$ [Word8] -> ByteString
BS.pack ([Word8] -> ByteString) -> [Word8] -> ByteString
forall a b. (a -> b) -> a -> b
$ String -> [Word8]
toBytes String
str of
    Right Text
t -> String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
t
    Either UnicodeException Text
_       -> Maybe String
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' Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
hexDigits Bool -> Bool -> Bool
&& Char
l' Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
hexDigits
        then Char -> Char -> Word8
forall a. (Num a, Enum a) => Char -> Char -> a
toByte Char
h' Char
l' Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: String -> [Word8]
toBytes String
sub
        else Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
'%') Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: String -> [Word8]
toBytes (Char
h Char -> String -> String
forall a. a -> [a] -> [a]
: Char
l Char -> String -> String
forall a. a -> [a] -> [a]
: String
sub)
      Char
ch:String
sub ->
        ByteString -> [Word8]
BSL.unpack (Builder -> ByteString
toLazyByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ Char -> Builder
charUtf8 Char
ch) [Word8] -> [Word8] -> [Word8]
forall a. [a] -> [a] -> [a]
++ String -> [Word8]
toBytes String
sub
    toByte :: Char -> Char -> a
toByte Char
h Char
l = Char -> a
forall a. (Num a, Enum a) => Char -> a
toNum Char
h a -> a -> a
forall a. Num a => a -> a -> a
* a
16 a -> a -> a
forall a. Num a => a -> a -> a
+ Char -> a
forall a. (Num a, Enum a) => Char -> a
toNum Char
l
    toNum :: Char -> a
toNum Char
ch = (a, Char) -> a
forall a b. (a, b) -> a
fst ((a, Char) -> a) -> (a, Char) -> a
forall a b. (a -> b) -> a -> b
$ Maybe (a, Char) -> (a, Char)
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (a, Char) -> (a, Char)) -> Maybe (a, Char) -> (a, Char)
forall a b. (a -> b) -> a -> b
$
      ((a, Char) -> Bool) -> [(a, Char)] -> Maybe (a, Char)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(a, Char)
x -> (a, Char) -> Char
forall a b. (a, b) -> b
snd (a, Char)
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
ch) ([(a, Char)] -> Maybe (a, Char)) -> [(a, Char)] -> Maybe (a, Char)
forall a b. (a -> b) -> a -> b
$ [a] -> String -> [(a, Char)]
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
  high :: Word8
high = Word8
code Word8 -> Word8 -> Word8
forall a. Integral a => a -> a -> a
`div` Word8
10
  low :: Word8
low  = Word8
code Word8 -> Word8 -> Word8
forall a. Integral a => a -> a -> a
`mod` Word8
10
  meta :: String
meta = GemResponse -> String
respMeta GemResponse
resp
  body :: ByteString
body = ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
"" (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ GemResponse -> Maybe ByteString
respBody GemResponse
resp

  builder :: Builder
builder
    =  Word8 -> Builder
word8Dec Word8
high
    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word8 -> Builder
word8Dec Word8
low
    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
charUtf8 Char
' '
    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
stringUtf8 String
meta
    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
stringUtf8 String
"\r\n"
    Builder -> Builder -> Builder
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'] String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
'a'..Char
'f']

--jl