@@ -1,3 +1,4 @@
1+{-# LANGUAGE TypeApplications #-}
12module TutorialD.Interpreter.Import.TutorialD where
23import ProjectM36.Base
34import TutorialD.Interpreter.Import.Base
@@ -9,25 +10,79 @@ import qualified Data.Text as T
910import Control.Exception
1011import qualified Data.ByteString as BS
1112import qualified Data.Text.Encoding as TE
12−--import a file containing TutorialD database context expressions
13+import qualified Text.URI as URI
14+import Text.URI (URI)
15+import Crypto.Hash.SHA256
16+import Data.ByteString.Base16 as B16
17+import Network.HTTP.Simple
18+import Network.HTTP.Types
19+--import a file containing TutorialD database context expressions via local files or HTTP/HTTPS
1320
14−importTutorialD :: FilePath -> IO (Either RelationalError DatabaseContextExpr)
15−importTutorialD pathIn = do
16− eTutdBytes <- try (BS.readFile pathIn) :: IO (Either IOError BS.ByteString)
17− case eTutdBytes of
18− Left err -> return $ Left (ImportError $ T.pack (show err))
19− Right tutdBytes ->
20− case TE.decodeUtf8' tutdBytes of
21− Left err -> pure (Left (ImportError $ T.pack (show err)))
22− Right tutdUtf8 ->
23− case parse multipleDatabaseContextExprP "import" tutdUtf8 of
24− --parseErrorPretty is new in megaparsec 5
25− Left err -> pure (Left (PM36E.ParseError (T.pack (show err))))
26− Right expr -> pure (Right expr)
27−
21+importTutorialDFromFile :: URI -> HashVerification -> IO (Either RelationalError DatabaseContextExpr)
22+importTutorialDFromFile fileURI mHash = do
23+ case URI.uriPath fileURI of
24+ Just (False, _) -> do
25+ eTutdBytes <- try (BS.readFile filePath) :: IO (Either IOError BS.ByteString)
26+ case eTutdBytes of
27+ Left err -> pure $ Left (ImportError (ImportFileError (T.pack (show err))))
28+ Right tutdBytes ->
29+ case validateBytes tutdBytes mHash of
30+ Left err -> pure (Left err)
31+ Right tutdBytes' -> importTutorialDBytes tutdBytes'
32+ _ -> pure (Left (ImportError (InvalidFileURIError (URI.render fileURI))))
33+ where
34+ filePath = drop (length ("file://" :: String)) (URI.renderStr fileURI)
35+
36+
37+importTutorialDBytes :: BS.ByteString -> IO (Either RelationalError DatabaseContextExpr)
38+importTutorialDBytes tutdBytes =
39+ case TE.decodeUtf8' tutdBytes of
40+ Left err -> pure (Left (ImportError (ImportFileDecodeError (T.pack (show err)))))
41+ Right tutdUtf8 ->
42+ case parse (multilineDatabaseContextExprP <* eof) "import" tutdUtf8 of
43+ --parseErrorPretty is new in megaparsec 5
44+ Left err -> pure (Left (PM36E.ParseError (T.pack (errorBundlePretty err))))
45+ Right expr -> pure (Right expr)
46+
47+importTutorialDViaHTTP :: URI -> HashVerification -> IO (Either RelationalError DatabaseContextExpr)
48+importTutorialDViaHTTP uri mHash = do
49+ reqURI <- parseRequest (URI.renderStr uri)
50+ response <- httpBS reqURI
51+ let scode = getResponseStatus response
52+ if scode == ok200 then
53+ let byteBody = getResponseBody response in
54+ case validateBytes byteBody mHash of
55+ Right byteBody' -> do
56+ importTutorialDBytes byteBody'
57+ Left err -> pure (Left err)
58+ else
59+ pure (Left (ImportError (ImportDownloadError (T.pack ("download failed: " <> show scode)))))
60+
61+validateBytes :: BS.ByteString -> HashVerification -> Either RelationalError BS.ByteString
62+validateBytes tutdBytes mHash =
63+ case mHash of
64+ Nothing -> pure tutdBytes
65+ Just expectedHashText ->
66+ case B16.decode (TE.encodeUtf8 expectedHashText) of
67+ Left _ -> Left (ImportError (InvalidSHA256Error expectedHashText))
68+ Right expectedHash | hashBytes == expectedHash -> pure tutdBytes
69+ | otherwise ->
70+ let p = TE.decodeUtf8 . B16.encode in
71+ Left (ImportError (SHA256MismatchError (p expectedHash) (p hashBytes)))
72+ where
73+ hashBytes = hash tutdBytes
74+
75+
2876tutdImportP :: Parser DatabaseContextDataImportOperator
2977tutdImportP = do
3078 reserved ":importtutd"
31− path <- quotedString
79+ uri <- quoted URI.parser
3280 spaceConsumer
33− return $ DatabaseContextDataImportOperator (T.unpack path) importTutorialD
81+ mhash <- optional (quoted hex)
82+ let handler =
83+ case URI.unRText <$> URI.uriScheme uri of
84+ Nothing -> fail "URI scheme missing"
85+ Just "file" -> importTutorialDFromFile
86+ Just scheme | scheme `elem` ["http", "https"] -> importTutorialDViaHTTP
87+ | otherwise -> fail ("unsupported URI scheme: " <> show scheme)
88+ pure $ DatabaseContextDataImportOperator uri mhash handler