Initial commit

.gitignore

@@ -0,0 +1,2 @@
+result
+dist/

ChangeLog.md

@@ -0,0 +1,5 @@
+# Revision history for rauhala-api
+
+## 0.1.0.0 -- YYYY-mm-dd
+
+* First version. Released on an unsuspecting world.

LICENSE

@@ -0,0 +1,30 @@
+Copyright (c) 2018, Mats Rauhala
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Mats Rauhala nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

default.nix

@@ -0,0 +1,3 @@
+{ haskellPackages, haskell }:
+
+haskellPackages.callCabal2nix "rauhala-api" ./. {}

executables/api.hs

@@ -0,0 +1,8 @@
+module Main where
+
+import Server
+import Network.Wai.Handler.Warp
+import Network.Wai.Middleware.Cors (simpleCors)
+
+main :: IO ()
+main = run 8081 (simpleCors application)

executables/generator.hs

@@ -0,0 +1,11 @@
+{-# Language TypeApplications #-}
+{-# Language NoImplicitPrelude #-}
+module Main where
+
+import API
+import Servant.JS
+import Data.Proxy (Proxy(..))
+import ClassyPrelude
+
+main :: IO ()
+main = putStrLn $ jsForAPI (Proxy @API) vanillaJS

rauhala-api.cabal

@@ -0,0 +1,66 @@
+-- Initial rauhala-api.cabal generated by cabal init.  For further
+-- documentation, see http://haskell.org/cabal/users-guide/
+
+name:                rauhala-api
+version:             0.1.0.0
+-- synopsis:
+-- description:
+license:             BSD3
+license-file:        LICENSE
+author:              Mats Rauhala
+maintainer:          mats@rauhala.info
+-- copyright:
+category:            Web
+build-type:          Simple
+extra-source-files:  ChangeLog.md
+cabal-version:       >=1.10
+
+library
+  exposed-modules:     API
+                     , API.IPFS
+                     , Server
+                     , Server.IPFS
+  -- other-modules:
+  -- other-extensions:
+  build-depends:       base >=4.10
+                     , servant
+                     , servant-server
+                     , servant-docs
+                     , classy-prelude
+                     , aeson
+                     , pandoc
+                     , http-media
+                     , dns
+                     , lens
+  hs-source-dirs:      src
+  default-language:    Haskell2010
+
+executable rauhala-api
+  main-is:             api.hs
+  -- other-modules:
+  -- other-extensions:
+  build-depends:       base >=4.10
+                     , rauhala-api
+                     , servant-server
+                     , wai
+                     , wai-cors
+                     , warp
+                     , mtl
+                     , classy-prelude
+                     , text
+                     , wai
+  hs-source-dirs:      executables
+  default-language:    Haskell2010
+
+executable generator
+  main-is:             generator.hs
+  -- other-modules:
+  -- other-extensions:
+  build-depends:       base >=4.10
+                     , rauhala-api
+                     , servant-js
+                     , mtl
+                     , classy-prelude
+                     , text
+  hs-source-dirs:      executables
+  default-language:    Haskell2010

release.nix

@@ -0,0 +1,28 @@
+{ pkgs ? import <nixpkgs> {} }:
+
+let
+  _pkgs = import (pkgs.fetchFromGitHub {
+    owner = "NixOS";
+    repo = "nixpkgs";
+    rev = "234a24cbeb66f70afaab9f13a5a9973c2fb956e0"; # LTS 12.10
+    sha256 = "1n0n6dwyllkddl4nxjhkr1cq7mpk786dsr6v36589c7flj8inbwf";
+  }) {};
+  inherit (_pkgs) haskellPackages haskell buildEnv;
+  pkg = import ./default.nix { inherit haskellPackages haskell; };
+  shell = buildEnv {
+    name = "shell";
+    paths = [];
+    buildInputs = [
+      _pkgs.binutils-unwrapped
+      haskellPackages.ghcid
+      haskellPackages.hasktags
+      (haskellPackages.ghcWithHoogle (_: pkg.buildInputs ++ pkg.propagatedBuildInputs))
+    ];
+  };
+
+in
+
+{
+  "rauhala-api" = pkg;
+  "shell" = shell;
+}

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