{-# 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
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
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
..}
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
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
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']