タイトルの通り、Haskell Stackで作成しているプロジェクトを、テスト用のディレクトリから正式なプロジェクト管理用ディレクトリに移動したところ、stack buildが失敗するようになってしまいました。
エラーメッセージは正確に記録しなかったのですが、/usr/bin/ld.goldがエラーを出していて、 プロジェクトが使用しているHaskellライブラリの.soファイルが見つからない、 といったようなメッセージを出力していました。
stack buildが通らなくなった時のメモを見てみましたが、libgmpといった、システム全体にインストールされているライブラリではないので、症状は異なります。 同ページに記載されていた、stack setup –reinstallを試してみましたが、相変わらずstack buildのエラーは同じでした。
結果としては、プロジェクトディレクトリにある、.stack-workディレクトリをrm -rfで削除して、再度stack buildしたら成功しました。
個人的なプロジェクトとして、ログイン機能を実装したWebアプリを作成したいと考えています。 独自のユーザ認証にするという方法もありますが、今回はGoogleのOAuth2を使う方法を検討しました。
HaskellのWebフレームワークであるSpockを使用しました。 また、OAuth2はwreqを使って、自分でHTTPリクエストを発行することで実装しました。
また、Webアプリ自体はポート8888でSSLを使用せずに待ち受けるようになっています。 SSL化をするためにnginxをインストールして、/etc/nginx/conf.d/test.confとして以下を作成します。
server {
listen 443;
server_name test.com;
ssl on;
ssl_certificate /etc/letsencrypt/live/test.com/fullchain.pem;
ssl_sertificate_key /etc/letsencrypt/live/test.com/privkey.pem;
ssl_session_timeout 15m;
ssl_protocols SSLv2 SSLv3 TLSv1;
ssl_ciphers HIGH:!aNULL:!MD5;
ssl_prefer_server_ciphers on;
proxy_set_header Host $host;
proxy_set_header X-Real-IP $remote_addr;
proxy_set_header X-Forwarded-Host $host;
proxy_set_header X-Forwarded-Server $host;
proxy_set_header X-Forwarded-For $proxy_add_x_forwarded_for;
location / {
proxy_pass http://localhost:8888/;
proxy_redirect default;
}
}
これでnginxをSSL対応リバースプロキシとして動作させ、同一マシン上で動くHaskell WebアプリにHTTPリクエストを転送することができます。
プログラムはモジュールに分割せず、全部を1ファイルにまとめて書いてしまいましたが、次のようになりました。
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables,FlexibleContexts #-}
module Main where
import Web.Spock (SpockM, get, root, param, getState, runQuery, text, redirect, (<//>), spock, runSpock, var)
import Web.Spock.Config
import Web.Spock.SessionActions
import Database.PostgreSQL.Simple
import Data.Pool
import Database.PostgreSQL.Simple.FromRow
import qualified Network.Wreq as W
import Network.Wreq (FormParam(..))
import Control.Lens
import qualified Control.Exception as E
import qualified Network.HTTP.Client as H
import Data.Aeson.Lens (_String, _Integer, key)
import Data.Aeson.Types (Value)
import Data.Map.Strict (Map, (!?), insert, empty, (!))
import Control.Monad.Trans
import Data.IORef
import Data.Monoid
import qualified Data.ByteString.Char8 as B
import Data.ByteString.Lazy (ByteString)
import qualified Data.Text as T
import qualified System.Random as R
type Sess = Map T.Text T.Text
data AppState = DummyAppState (IORef Int)
type Email = String
type ErrorMsg = String
type Resp = W.Response (Map String Value)
redirect_uri = "https://(GoogleからリダイレクトされるURL)/google_oauth_callback" :: T.Text
client_id = "(Googleから発行されるClient ID)" :: T.Text
client_secret = "(Googleから発行されるClient Secret)" :: T.Text
auth_uri = "https://accounts.google.com/o/oauth2/v2/auth" :: T.Text
exchange_uri = "https://www.googleapis.com/oauth2/v4/token" :: String
api_uri = "https://www.googleapis.com/oauth2/v2/userinfo" :: String
scope = "https://www.googleapis.com/auth/userinfo.email email" :: T.Text
db_name = "(データベース名)"
db_user = "(データベースユーザ名)"
db_pwd = "(データベースパスワード)"
main :: IO ()
main =
do ref <- newIORef 0
pool <- createPool (connect defaultConnectInfo
{ connectDatabase = db_name,
connectUser = db_user,
connectPassword = db_pwd })
close 1 10 10
spockCfg <- defaultSpockCfg empty (PCPool pool) (DummyAppState ref)
runSpock 8888 (spock spockCfg app)
-- Here "id_token" contains JWT, which includes email address (See https://developers.google.com/identity/protocols/OpenIDConnect)
debugExchangeResult :: W.Response ByteString -> IO ()
debugExchangeResult r = do
res <- W.asJSON r :: IO Resp
putStrLn "======================"
putStrLn $ show $ r ^. W.responseBody
putStrLn $ dbgMsg res "access_token"
putStrLn $ dbgMsg res "token_type"
putStrLn $ dbgMsg res "expires_in"
putStrLn $ dbgMsg res "refresh_token"
putStrLn "======================"
where dbgMsg res str = str ++ " : " ++ show ((res ^. W.responseBody) !? str)
getEmail :: String -> IO (Either ErrorMsg Email)
getEmail auth_code = do
putStrLn ("authorization code : " ++ auth_code)
r <- W.post exchange_uri
["code" := auth_code,
"client_id" := client_id,
"client_secret" := client_secret,
"redirect_uri" := redirect_uri,
"grant_type" := ("authorization_code" :: T.Text)]
let status_code = r ^. W.responseStatus . W.statusCode
if status_code == 200 then
do
let access_token = show $ r ^. W.responseBody . key "access_token" . _String
let opts = W.defaults & W.header "Authorization" .~ [B.pack $ "Bearer " ++ access_token]
debugExchangeResult r
r2 <- W.getWith opts api_uri
putStrLn $ show (r2 ^? W.responseBody)
let email = show (r2 ^. W.responseBody . key "email" . _String)
case email of
"" -> return $ Left ""
_ -> return $ Right email
else
return $ Left "failed to exchange token"
handle_callback = do
(Just code :: Maybe String) <- param "code"
(Just state :: Maybe String) <- param "state"
m <- readSession
if (m ! "state" /= T.pack state) then
text "state invalid"
else
(liftIO $ getEmail code `E.catch` handler) >>= handle_result
where handle_result (Left msg) = text ("error " <> T.pack msg)
handle_result (Right mail) = text ("Logged in as: " <> T.pack mail)
handler e@(H.HttpExceptionRequest req cont) =
do liftIO $ putStrLn $ show cont
return $ Left $ show cont
handle_hello name = do
(DummyAppState ref) <- getState
[Only xs] <- runQuery $ \conn -> query_ conn "select 1+1;" :: IO [Only Int]
liftIO $ putStrLn $ show xs
num <- liftIO $ atomicModifyIORef' ref $ \i -> (i+1, i+1)
m <- readSession
writeSession $ insert "name" name m
text ("Hello " <> name <> ", number " <> T.pack (show num))
handle_login = do
g <- liftIO $ R.newStdGen
let state = take 30 (R.randomRs ('a', 'z') g)
liftIO $ putStrLn state
sessionRegenerateId
m <- readSession
writeSession $ insert "state" (T.pack state) m
redirect (T.concat [auth_uri, "?client_id=", client_id,
"&redirect_uri=", redirect_uri,
"&state=", T.pack state,
"&scope=", scope, "&access_type=online&response_type=code"])
app :: SpockM Connection Sess AppState ()
app =
do get root $
do m <- readSession
let name = m !? "name"
case name of
Nothing -> text "Hello World"
Just n -> text ("Hello World, " <> n)
get ("hello" <//> var) handle_hello
get "login" handle_login
get "google_oauth_callback" handle_callback
上記コードでは、OAuth2を用いてログインしたユーザのメールアドレスを取得しています。アクセストークン取得時にJWT(JSON Web Token)がid_tokenに発行されるので、それをデコードして、中のデータから取り出しても良いはずですが、もう一度APIを呼び出すことで、その結果からアドレスを取り出しています。
また、データベースやセッション管理の検証のためのコードも追加されています。実装が正しいかあまり自信はありませんが、CSRF対策ということで、認証する際のstateパラメタに、セッションに結びついたランダム文字列を渡し、コールバックで戻されるstateパラメタの値と、セッションに保存しておいた文字列が等しいことを検証しています。
セッションが保持する情報は、文字列から文字列への連想配列(Map)としています。
package.yamlのdependenciesは次のように記述しています。
dependencies:
- base >= 4.7 && < 5
- Spock == 0.13.0.0
- Spock-core == 0.13.0.0
- reroute == 0.5.0.0
- mtl >= 2.2
- text >= 1.2.3
- postgresql-simple >= 0.5.4
- resource-pool >= 0.2.3
- wreq >= 0.5.3
- lens >= 4.16
- lens-aeson >= 1.0.2
- bytestring >= 0.9.1
- aeson >= 1.2.1.0
- containers >= 0.5.11
- random >= 1.1
- http-client >= 0.5.14
stack.yamlのresolverはlts-12.25とし、extra-depsは次のように記述しています。
extra-deps:
- Spock-0.13.0.0
- Spock-core-0.13.0.0
- reroute-0.5.0.0
これで、所望のWebアプリを作成するための技術的な方式の検討ができました。あとはひたすらページを作成し、データベースとのグルーロジックを追加して行けば、完成まで持って行けそうです。 基本的にフロントエンドに動的要素は必要ではないと考えていますが、もし必要ならVue.jsあたりを使おうかと思います。
前回の記事で、HTMLのCanvas要素とWebSocketsの組み合わせで画像転送と表示の実験を行いました。 想定よりもHaskellで作ったWebSocketsサーバの動作が重いため、少し調査して改善しました。
import Control.Exception (finally)
import Control.Monad (forM_, forever)
import qualified Network.WebSockets as WS
import qualified Data.ByteString.Char8 as C
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Internal as BI
import Foreign.Ptr (plusPtr, Ptr)
import Foreign.Storable (poke)
import Data.Word (Word8)
main :: IO ()
main = WS.runServer "127.0.0.1" 9160 application
-- BI.create :: Int -> (Ptr Word8 -> IO ()) -> IO ByteString
fill :: Int32 -> Ptr Word8 -> IO ()
fill seed ptr =
go (0, 0) ptr
where
go (j, i) ptr = do
let val = fromIntegral $ seed + i + j
poke ptr val
if i == 1919 then
if j == 1079 then
return ()
else
go (j+1, 0) $ ptr `plusPtr` 1
else
go (j, i+1) $ ptr `plusPtr` 1
application :: WS.ServerApp
application pending = do
conn <- WS.acceptRequest pending
WS.forkPingThread conn 30
forever $ do
bytes <- WS.receiveData conn
let seed:_ = L.unpack bytes
let seed2 = fromIntegral (toInteger seed)
buf <- BI.create (1920*1080) (fill seed2)
WS.sendBinaryData conn buf
ByteString.Internalのcreate関数を使って、転送するバッファの生成と初期化を同時に行います。 fill関数には、createで確保される領域へのポインタが渡されるので、poke関数を使って当該領域に1つずつデータを書き込みます。 go関数で、1画面分ループします。1ループごとにポインタを1進める(plusPtr)ことで、次のWord8にアクセスできます。
このプログラムを試してみると、FirefoxはCPUを60%程度消費する一方、サーバ側は15%程度で済んでいます。
クライアントからリクエストがあるごとに毎回create関数を呼び出しているので、 あまり効率は良くないと思いますが、それでも初期のサーバ律速であった状況からは大幅に改善しました。
もっとも、このようなプログラムにしてしまうと、中身はCで記述するのと大差ないので、 あえてHaskellで書く意義はかなり失われている感があります。
前回、HTMLでCanvasを使用した描画を試しました。 今回は、HaskellでWebSocketsのサーバを作成し、当該サーバからバイナリデータを受信してCanvasに描画するようにしました。
まずは、ブラウザで動作させるファイルです。
<html>
<body>
<script
src="https://code.jquery.com/jquery-3.2.1.js"
integrity="sha256-DZAnKJ/6XZ9si04Hgrsxu/8s717jcIzLy3oi35EouyE="
crossorigin="anonymous"></script>
<p><div id="time">Time[ms]</div></p>
<canvas id="canvas" width="1920" height="1080"></canvas>
<script type="text/javascript">
$(window).on('load', function(){
var tm = 0;
var canvas = $('#canvas').get(0);
var width = canvas.width;
var height = canvas.height;
var ctx = canvas.getContext('2d');
var imageData = ctx.getImageData(0, 0, width, height);
var buf = new ArrayBuffer(imageData.data.length);
var buf8 = new Uint8ClampedArray(buf);
var data = new Uint32Array(buf);
var start_ms = performance.now();
var elapsed_ms;
var cn = new WebSocket('ws://127.0.0.1:9160/');
cn.addEventListener('message', function(ev){
var reader = new FileReader();
reader.addEventListener("loadend", function(){
var ary = new Uint8Array(reader.result);
//console.log(ary[0]);
for (var j = 0; j < height; j++){
for (var i = 0; i < width; i++){
var val = ary[j*width+i];
data[j*width+i] = (255<<24) | (val<<16) | (val<<8) | val;
}
}
imageData.data.set(buf8);
ctx.putImageData(imageData, 0, 0);
if (tm % 60 == 0){
var current = performance.now();
elapsed_ms = current - start_ms;
$("#time").text(elapsed_ms/60.0 + "[ms]");
start_ms = current;
}
});
reader.readAsArrayBuffer(ev.data);
});
var getData = function(){
var abuf = new ArrayBuffer(1);
var view = new Uint8Array(abuf);
view[0] = tm & 0xFF;
cn.send(abuf);
tm++;
setTimeout(getData, 1);
}
cn.addEventListener('open', function(){
getData();
});
});
</script>
</body>
</html>
上記のとおり、ローカルホストで動作するWebSocketサーバとの通信を開き、getData関数を繰り返し呼び出します。
getData関数では、1バイトの配列要素に、0-255で巡回する値を入れて、WebSocketサーバに送ります。
また、受信するmessageのイベントハンドラでは、ev.dataがJavaScriptのBlobなので、readAsArrayBufferでloadenedハンドラと結びつけます。 当該ハンドラでは、reader.resultがサーバから送られてきた生データの配列になります。これを前回の記事と同様、Canvasに描画します。
一方HaskellでのWebSocketsサーバは次コードです。
{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}
module Main where
import Lib
import Data.Int
import Control.Exception (finally)
import Control.Monad (forever)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Network.WebSockets as WS
import qualified Data.ByteString.Char8 as C
import qualified Data.ByteString.Lazy as L
main :: IO ()
main = WS.runServer "127.0.0.1" 9160 application
application :: WS.ServerApp
application pending = do
conn <- WS.acceptRequest pending
WS.forkPingThread conn 30
forever $ do
bytes <- WS.receiveData conn
let seed:_ = L.unpack bytes
let seed2 = fromIntegral (toInteger seed)
WS.sendBinaryData conn (L.unfoldr (genData seed2) (0, 0))
genData (seed :: Int32) (j, i) =
if j >= 1080 then Nothing
else
if i == 1919 then
Just (fromIntegral (seed+i+j), (j+1, 0))
else
Just (fromIntegral (seed+i+j), (j, i+1))
何かデータを受信したら、先頭バイトを取り出し、Word8に変換して(fromIntegral . toIntegerの組み合わせ)、 unfoldrにgenData関数を渡して(初期値としてWord8を渡す)、ByteStringを生成させます。
genData関数がNothingを返すと、ByteStringの生成は終了されます。 Just (a, b)を返すと、aがByteStringの新しい要素となり、bがgenDataを再度呼び出すために用いられます。
結局、(0, 0)からスタートして、(1079, 1919)まで、(y座標, x座標)の組が引数として渡されるようにしています。
生成されたByteStringはsendBinaryData関数でクライアントに返されます。
WindowsにStackを使ってGHCや必要なライブラリをインストールし、サーバを動作させて、 Firefoxで同一マシンからアクセスしてみました。
…かなり遅い。前回はFirefoxのプロセスが30%程度CPUを消費していましたが、今回は15%未満でした。 その代わり、WebSocketsのサーバを動作させているコマンドプロンプトのプロセスが50%消費しています。 どうやらサーバ側が律速しているようです。
まだ詳細に調査していませんが、sendBinaryDataで単純にファイルの中身のようなデータを送る場合は、 もっと高速に動作している印象でした。そのことからすると、genDataの繰り返しが遅いのではないかと想像しています。
2017/12/20追記：ちょっと調べたところ、ByteStringはBuilderを使って生成したほうが速いらしいので、 Haskell側のプログラムを以下のように修正しました。
{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}
module Main where
import Lib
import Data.Int
import Control.Exception (finally)
import Control.Monad (forM_, forever)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Network.WebSockets as WS
import qualified Data.ByteString.Char8 as C
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Builder as B
main :: IO ()
main = WS.runServer "127.0.0.1" 9160 application
infixr 4 <>
(<>) = mappend
application :: WS.ServerApp
application pending = do
conn <- WS.acceptRequest pending
WS.forkPingThread conn 30
forever $ do
bytes <- WS.receiveData conn
let seed:_ = L.unpack bytes
let seed2 = fromIntegral (toInteger seed)
WS.sendBinaryData conn (B.toLazyByteString (genData seed2 (0, 0)))
genData (seed :: Int32) (j, i) =
if i == 1919 then
if j == 1079 then
B.word8 (fromIntegral (seed+i+j))
else
B.word8 (fromIntegral (seed+i+j)) <> genData seed (j+1, 0)
else
B.word8 (fromIntegral (seed+i+j)) <> genData seed (j, i+1)
大枠は同じですが、unfoldrの代わりに、toLazyByteStringを使用し、 genDataはword8を使用してBuilderを生成します。各画素のBuilderはmappend(<>)にて連結されます。
これで試してみたところ、Firefoxは30%程度まで負荷が上がったので、効率は多少上がったかもしれません。 それでも、まだHaskell側が50%消費しています。ごく単純なプログラムなので、これはいただけません。
仕組みの検証はできましたが、もう少し速くしたいところです。 今度はRustあたりで作成してみようかと検討しています。
2017/12/21追記：ByteStringあれこれを見ると、 Internalを使わないとパフォーマンスを出すのは難しそうですね。 mallocByteStringしてからscanrなどで置き換えていくのが良いのかもしれません。 また別途試してみたいと思います。
© 2019 東京に住むプログラマ (webmaster@living-in.tokyo). Based on MH Magazine lite.