Created
March 14, 2017 12:03
-
-
Save naoto-ogawa/eab6669ac7bcbedae0497f58ae6f4ac5 to your computer and use it in GitHub Desktop.
servant file upload sample
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# LANGUAGE DataKinds #-} | |
{-# LANGUAGE DeriveGeneric #-} | |
{-# LANGUAGE FlexibleInstances #-} | |
{-# LANGUAGE GeneralizedNewtypeDeriving #-} | |
{-# LANGUAGE MultiParamTypeClasses #-} | |
{-# LANGUAGE OverloadedStrings #-} | |
{-# LANGUAGE ScopedTypeVariables #-} | |
{-# LANGUAGE TypeOperators #-} | |
import Control.Monad.IO.Class -- liftIO | |
import Control.Monad.Trans.Except -- Handler | |
import Data.Aeson.Types -- JSON | |
import Data.Aeson.Parser -- JSON | |
import GHC.Generics | |
import Network.Wai.Handler.Warp | |
import Servant | |
import Servant.Multipart -- file upload | |
import qualified Data.Text as T | |
data Ret = Ret { msg :: String , len:: Int} deriving (Eq, Show, Generic) | |
instance ToJSON Ret | |
type MyAPI = "file" :> MultipartForm MultipartData :> Put '[JSON] Ret | |
upload :: MultipartData -> Handler Ret | |
upload multipartData = do | |
mapM_ (liftIO . putStrLn . show ) (files multipartData) -- log | |
let content = lookupFile "upfile" multipartData | |
case content of | |
Just file -> | |
liftIO $ do | |
c <- readFile (fdFilePath file) | |
putStrLn c | |
return $ Ret {msg= "uploaded", len = (length c)} | |
Nothing -> | |
liftIO $ do | |
putStrLn "not exist" | |
return $ Ret {msg= "\"upfile doesn't exist\"", len = -1} | |
myServer :: Server MyAPI | |
myServer = upload | |
myProxy :: Proxy MyAPI | |
myProxy = Proxy | |
myApp :: Application | |
myApp = serve myProxy myServer | |
main :: IO () | |
main = run 8081 myApp | |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment