blob: 94c2b177f697c8ee6c955a76cb5279598ccc7c5b (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
|
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
module Web.ZeroBin (
Expiration(..),
ZeroBinError(..),
share
) where
import Control.Exception (Exception)
import Control.Exception.Base (throwIO)
import Data.ByteString (ByteString)
import Data.ByteString.Base64 (encode)
import Data.Maybe (fromJust)
import Data.Typeable (Typeable)
import GHC.Generics (Generic)
import Web.ZeroBin.SJCL (encrypt, Content)
import Web.ZeroBin.Utils (makePassword)
import qualified Data.Aeson as JSON
import qualified Data.ByteString.Char8 as C
import qualified Data.ByteString.Lazy as L
import qualified Network.HTTP.Conduit as HTTP
data Response = Response {
status :: String
, message :: Maybe String
, paste :: Maybe String
} deriving (Generic, Show)
instance JSON.FromJSON Response
data ZeroBinError = ZeroBinError String
deriving (Show, Typeable)
instance Exception ZeroBinError
data Expiration
= Once
| Day
| Week
| Month
| Never
form :: Expiration -> String
form Once = "burn_after_reading"
form Day = "1_day"
form Week = "1_week"
form Month = "1_month"
form Never = "never"
post :: String -> Expiration -> Content -> IO String
post bin ex ct = do
req' <- HTTP.parseUrl $ bin ++ "/paste/create"
let req = HTTP.urlEncodedBody
[ (C.pack "expiration" , C.pack $ form ex)
, (C.pack "content" , L.toStrict $ JSON.encode ct)
] req'
manager <- HTTP.newManager HTTP.tlsManagerSettings
response <- HTTP.httpLbs req manager
let resp = fromJust . JSON.decode $ HTTP.responseBody response
case status resp of
"ok" -> return $ bin ++ "/paste/" ++ (fromJust . paste) resp
_ -> throwIO . ZeroBinError $ (fromJust . message) resp
share :: String -> Expiration -> ByteString -> IO String
share bin ex txt = do
pwd <- makePassword 33
cnt <- encrypt pwd (encode txt)
uri <- post bin ex cnt
return $ uri ++ "#" ++ pwd
|
