Initial commit

src/API.hs

@@ -0,0 +1,35 @@
+{-# Language DataKinds #-}
+{-# Language NoImplicitPrelude #-}
+{-# Language TypeOperators #-}
+{-# Language MultiParamTypeClasses #-}
+{-# Language OverloadedStrings #-}
+module API where
+
+import Servant.API
+import ClassyPrelude
+
+import qualified API.IPFS as IPFS
+
+import Text.Pandoc.Readers.Markdown (readMarkdown)
+import Text.Pandoc.Writers.HTML (writeHtml5String)
+import Text.Pandoc.Class (runPure, PandocMonad)
+import Text.Pandoc.Options (def)
+import Network.HTTP.Media ((//), (/:))
+
+data HTML
+
+newtype Docs = Docs Text
+
+instance MimeRender PlainText Docs where
+  mimeRender _ (Docs d) = fromStrict $ encodeUtf8 d
+
+instance MimeRender HTML Docs where
+  mimeRender _ (Docs d) = either (encodeUtf8 . pack . show) (fromStrict . encodeUtf8) $ runPure (writeHtml5String def <=< readMarkdown def $ d)
+
+instance Accept HTML where
+  contentType _ = "text" // "html" /: ("charset", "utf-8")
+
+type API = "ipfs" :> IPFS.API
+
+type DocumentedAPI = API
+  :<|> "help" :> Get '[PlainText, HTML] Docs

src/API/IPFS.hs

@@ -0,0 +1,24 @@
+{-# Language DataKinds #-}
+{-# Language TypeOperators #-}
+{-# Language GeneralizedNewtypeDeriving #-}
+{-# Language MultiParamTypeClasses #-}
+{-# Language NoImplicitPrelude #-}
+{-# Language DeriveGeneric #-}
+{-# Language OverloadedStrings #-}
+module API.IPFS where
+
+import ClassyPrelude
+import Servant.API
+import Data.Aeson
+import Servant.Docs (singleSample, ToSample(..))
+
+newtype VersionHash = VersionHash Text
+  deriving (Show, ToJSON)
+
+instance ToSample VersionHash where
+  toSamples _ = singleSample (VersionHash "QmQdyH1o6g7Q1p4rJCWABTup5KgxYK1T9AZxBWpnhgMQQQ")
+
+instance MimeRender PlainText VersionHash where
+  mimeRender _ (VersionHash h) = fromStrict . encodeUtf8 $ h
+
+type API = "current" :> Get '[JSON, PlainText] VersionHash

src/Server.hs

@@ -0,0 +1,21 @@
+{-# Language NoImplicitPrelude #-}
+{-# Language TypeApplications #-}
+{-# Language OverloadedStrings #-}
+{-# Language GeneralizedNewtypeDeriving #-}
+module Server where
+
+import API
+import ClassyPrelude
+import Servant
+import qualified Servant.Docs as Docs
+
+import qualified Server.IPFS as IPFS
+
+
+server :: Server DocumentedAPI
+server = IPFS.handler :<|> pure mkDocs
+  where
+    mkDocs = Docs $ pack $ Docs.markdown $ Docs.docs (Proxy @API)
+
+application :: Application
+application = serve (Proxy @DocumentedAPI) server

src/Server/IPFS.hs

@@ -0,0 +1,28 @@
+{-# Language NoImplicitPrelude #-}
+{-# Language OverloadedStrings #-}
+{-# Language ViewPatterns #-}
+{-# Language FlexibleContexts #-}
+module Server.IPFS where
+
+import API.IPFS
+import Servant
+import ClassyPrelude
+
+import Network.DNS
+
+import Control.Lens (over, _Left)
+
+handler :: Server API
+handler = liftIO getHash >>= either (const (throwError err500)) return
+  where
+    getHash :: IO (Either String VersionHash)
+    getHash =
+      makeResolvSeed defaultResolvConf >>=
+        \rs -> withResolver rs $ \resolver -> do
+          eTxt <- over _Left show <$> lookupTXT resolver "rauhala.info"
+          -- This is terrible
+          return (eTxt >>= maybe (Left "Could not find dnslink") Right . hash)
+    hash [x] = case x of
+                    (stripPrefix "dnslink" -> Just h) -> Just . VersionHash . decodeUtf8 $ h
+                    _ -> Nothing
+    hash _ = Nothing