|
| 1 | +{-# LANGUAGE DeriveGeneric #-} |
| 2 | +{-# LANGUAGE OverloadedStrings #-} |
| 3 | +{-# LANGUAGE ScopedTypeVariables #-} |
| 4 | + |
| 5 | +module VVA.Ipfs (ipfsUpload, IpfsError(..)) where |
| 6 | + |
| 7 | +import Control.Exception (SomeException, try) |
| 8 | +import Control.Monad.IO.Class (liftIO) |
| 9 | +import qualified Data.Aeson as A |
| 10 | +import Data.Aeson (FromJSON(parseJSON), withObject, (.:), eitherDecode, ToJSON(..), encode,(.=),object) |
| 11 | +import qualified Data.ByteString.Lazy as LBS |
| 12 | +import Data.Text (Text) |
| 13 | +import qualified Data.Text.Encoding as TE |
| 14 | +import GHC.Generics (Generic) |
| 15 | +import Network.HTTP.Client (newManager, parseRequest, httpLbs, method, requestHeaders, RequestBody(..), Request, responseBody, responseStatus) |
| 16 | +import Network.HTTP.Client.TLS (tlsManagerSettings) |
| 17 | +import Network.HTTP.Client.MultipartFormData (formDataBody, partBS, partFileRequestBody) |
| 18 | +import Network.HTTP.Types.Status (statusIsSuccessful, Status, status503, status400) |
| 19 | +import qualified Data.ByteString.Lazy.Char8 as LBS8 |
| 20 | +import qualified Data.Text.Lazy as TL |
| 21 | +import qualified Data.Text.Lazy.Encoding as TL |
| 22 | +import qualified Data.Text as T |
| 23 | +import Servant.Server (ServerError (errBody)) |
| 24 | +import Servant.Exception (ToServantErr(..), Exception(..)) |
| 25 | + |
| 26 | + |
| 27 | +data PinataData = PinataData |
| 28 | + { cid :: Text |
| 29 | + , size :: Int |
| 30 | + , created_at :: Text |
| 31 | + , isDuplicate :: Maybe Bool |
| 32 | + } deriving (Show, Generic) |
| 33 | + |
| 34 | +instance FromJSON PinataData |
| 35 | + |
| 36 | +data PinataSuccessResponse = PinataSuccessResponse |
| 37 | + { pinataData :: PinataData |
| 38 | + } deriving (Show) |
| 39 | + |
| 40 | +instance FromJSON PinataSuccessResponse where |
| 41 | + parseJSON = withObject "PinataSuccessResponse" $ \v -> PinataSuccessResponse |
| 42 | + <$> v .: "data" |
| 43 | + |
| 44 | +data IpfsError |
| 45 | + = PinataConnectionError String |
| 46 | + | PinataAPIError Status LBS.ByteString |
| 47 | + | PinataDecodingError String LBS.ByteString |
| 48 | + | IpfsUnconfiguredError |
| 49 | + | OtherIpfsError String |
| 50 | + deriving (Show, Generic) |
| 51 | + |
| 52 | +instance ToJSON IpfsError where |
| 53 | + toJSON (PinataConnectionError msg) = |
| 54 | + object ["errorType" .= A.String "PinataConnectionError", "message" .= msg] |
| 55 | + |
| 56 | + toJSON (PinataAPIError status body) = |
| 57 | + object |
| 58 | + [ "errorType" .= A.String "PinataAPIError" |
| 59 | + , "message" .= ("Pinata API returned error status : " ++ show status) |
| 60 | + , "pinataResponse" .= object |
| 61 | + [ "status" .= show status |
| 62 | + , "body" .= TL.unpack (TL.decodeUtf8 body) |
| 63 | + ] |
| 64 | + ] |
| 65 | + |
| 66 | + toJSON (PinataDecodingError msg body) = |
| 67 | + object |
| 68 | + [ "errorType" .= A.String "PinataDecodingError" |
| 69 | + , "message" .= msg |
| 70 | + , "pinataResponse" .= object |
| 71 | + [ "status" .= ("unknown" :: String) |
| 72 | + , "body" .= TL.unpack (TL.decodeUtf8 body) |
| 73 | + ] |
| 74 | + ] |
| 75 | + |
| 76 | + toJSON IpfsUnconfiguredError = |
| 77 | + object ["errorType" .= A.String "IpfsUnconfiguredError", "message" .= ("Backend is not configured for upfs upload" :: String)] |
| 78 | + |
| 79 | + toJSON (OtherIpfsError msg) = |
| 80 | + object ["errorType" .= A.String "OtherIpfsError", "message" .= msg] |
| 81 | + |
| 82 | + |
| 83 | +instance Exception IpfsError |
| 84 | + |
| 85 | + |
| 86 | + |
| 87 | +instance ToServantErr IpfsError where |
| 88 | + status (OtherIpfsError _) = status400 |
| 89 | + status _ = status503 |
| 90 | + |
| 91 | + message (PinataConnectionError msg) = T.pack ("Pinata service connection error: " <> msg) |
| 92 | + message (PinataAPIError status body) = T.pack ("Pinata API error: " <> show status <> " - " <> LBS8.unpack body) |
| 93 | + message (PinataDecodingError msg body) = T.pack ("Pinata decoding error: " <> msg <> " - " <> LBS8.unpack body) |
| 94 | + message IpfsUnconfiguredError = T.pack ("Backend is not configured to support ipfs upload") |
| 95 | + message (OtherIpfsError msg) = T.pack msg |
| 96 | + |
| 97 | +ipfsUpload :: Maybe Text -> Text -> LBS.ByteString -> IO (Either IpfsError Text) |
| 98 | +ipfsUpload maybeJwt fileName fileContent = |
| 99 | + case maybeJwt of |
| 100 | + Nothing -> pure $ Left $ IpfsUnconfiguredError |
| 101 | + Just "" -> pure $ Left $ IpfsUnconfiguredError |
| 102 | + Just jwt -> do |
| 103 | + manager <- newManager tlsManagerSettings |
| 104 | + initialRequest <- parseRequest "https://uploads.pinata.cloud/v3/files" |
| 105 | + let req = initialRequest |
| 106 | + { method = "POST" |
| 107 | + , requestHeaders = [("Authorization", "Bearer " <> TE.encodeUtf8 jwt)] |
| 108 | + } |
| 109 | + result <- try $ flip httpLbs manager =<< formDataBody |
| 110 | + [ partBS "network" "public" |
| 111 | + , partFileRequestBody "file" (T.unpack fileName) $ RequestBodyLBS fileContent |
| 112 | + ] |
| 113 | + req |
| 114 | + |
| 115 | + case result of |
| 116 | + Left (e :: SomeException) -> do |
| 117 | + let errMsg = show e |
| 118 | + liftIO $ putStrLn errMsg |
| 119 | + pure $ Left $ PinataConnectionError errMsg |
| 120 | + Right response -> do |
| 121 | + let body = responseBody response |
| 122 | + let status = responseStatus response |
| 123 | + if statusIsSuccessful status |
| 124 | + then case eitherDecode body of |
| 125 | + Left err -> do |
| 126 | + let errMsg = "Failed to decode Pinata API reponse: " <> err |
| 127 | + liftIO $ putStrLn errMsg |
| 128 | + pure $ Left $ PinataDecodingError errMsg body |
| 129 | + Right (res :: PinataSuccessResponse) -> pure $ Right $ cid $ pinataData res |
| 130 | + else do |
| 131 | + let errMsg = "Pinata API request failed with status: " <> show status |
| 132 | + liftIO $ putStrLn errMsg |
| 133 | + pure $ Left $ PinataAPIError status body |
0 commit comments