1 files changed, 80 insertions, 0 deletions
diff --git a/lib/Uris.hs b/lib/Uris.hs
new file mode 100644
index 0000000..dfbd454
--- /dev/null
+++ b/lib/Uris.hs
@@ -0,0 +1,80 @@
+{-# LANGUAGE DataKinds        #-}
+{-# LANGUAGE DeriveAnyClass   #-}
+{-# LANGUAGE DeriveGeneric    #-}
+{-# LANGUAGE RecordWildCards  #-}
+{-# LANGUAGE TypeApplications #-}
+
+-- | Functions to deal with uris and custom uri schemes
+module Uris where
+
+
+
+import           Control.Monad           (unless)
+import           Data.Aeson              (FromJSON (..), Options (..),
+                                          SumEncoding (UntaggedValue),
+                                          defaultOptions, genericParseJSON)
+import           Data.Data               (Proxy)
+import           Data.Either.Combinators (maybeToRight)
+import           Data.Map.Strict         (Map)
+import qualified Data.Map.Strict         as M
+import           Data.Text               (Text)
+import           GHC.Generics            (Generic)
+import           GHC.TypeLits            (KnownSymbol, symbolVal)
+import           Text.Regex.TDFA         ((=~))
+
+data Substitution =
+    Prefixed { prefix :: Text, blocked :: [Text], allowed :: [Text], scope :: [String] }
+  | Explicit { substs :: Map Text Text, scope :: [String] }
+  | Allowed  { scope :: [String] }
+  deriving (Generic, Show)
+
+
+instance FromJSON Substitution where
+  parseJSON = genericParseJSON defaultOptions
+    { sumEncoding = UntaggedValue
+    , rejectUnknownFields = True
+    }
+
+type SchemaSet = Map Text Substitution
+
+
+extractDomain :: Text -> Maybe Text
+extractDomain url =
+  let (_,_,_,matches) = url =~ "^https://([^/]+)/?.*$" :: (Text,Text,Text,[Text])
+  in case matches of
+      [domain] -> Just domain
+      _        -> Nothing
+
+parseUri :: Text -> Maybe (Text, Text, Text)
+parseUri uri =
+  let (_,_,_,matches) = uri =~ "^([a-zA-Z0-9]+)://([^/]+)(/?.*)$" :: (Text,Text,Text,[Text])
+  in case matches of
+    [schema, domain, rest] -> Just (schema, domain, rest)
+    _                      -> Nothing
+
+data SubstError =
+    SchemaDoesNotExist Text
+  | NotALink
+  | IsBlocked
+  | InvalidLink
+  | WrongScope Text
+
+
+applySubst :: KnownSymbol s => Proxy s -> SchemaSet -> Text -> Either SubstError Text
+applySubst s substs uri =  do
+  (schema, domain, rest) <- note NotALink $ parseUri uri
+  rules <- note (SchemaDoesNotExist schema) ( M.lookup schema substs)
+  unless (symbolVal s `elem` scope rules)
+    $ Left (WrongScope schema)
+  case rules of
+    Explicit table _  -> do
+      prefix <- note InvalidLink $ M.lookup domain table
+      pure (prefix <> rest)
+    Prefixed {..}
+      | domain `elem` blocked -> Left IsBlocked
+      | domain `elem` allowed -> Right uri
+      | otherwise -> Right (prefix <> domain <> rest)
+    Allowed _ -> Right uri
+  where note = maybeToRight
+
+